From f24c50339bb8fd824a27b87dd1593f657cd7b4c7 Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Mon, 25 Jan 2021 12:10:30 +0100 Subject: [PATCH] Strip down format. More early work on compiler. Add testsuite (doesn't work yet). --- .gitignore | 1 + gf.cabal | 49 +++++++++++++ src/compiler/GF/Compile.hs | 2 +- src/compiler/GF/Compile/GrammarToLPGF.hs | 60 +++++++++++++--- src/runtime/haskell/LPGF.hs | 90 +++--------------------- testsuite/lpgf/Zero.gf | 12 ++++ testsuite/lpgf/ZeroEng.gf | 19 +++++ testsuite/lpgf/ZeroGer.gf | 28 ++++++++ testsuite/lpgf/run.hs | 76 ++++++++++++++++++++ 9 files changed, 245 insertions(+), 92 deletions(-) create mode 100644 testsuite/lpgf/Zero.gf create mode 100644 testsuite/lpgf/ZeroEng.gf create mode 100644 testsuite/lpgf/ZeroGer.gf create mode 100644 testsuite/lpgf/run.hs diff --git a/.gitignore b/.gitignore index 01b58ccb4..d8ce5494b 100644 --- a/.gitignore +++ b/.gitignore @@ -5,6 +5,7 @@ *.jar *.gfo *.pgf +*.lpgf debian/.debhelper debian/debhelper-build-stamp debian/gf diff --git a/gf.cabal b/gf.cabal index 95de3cc95..1433ed98d 100644 --- a/gf.cabal +++ b/gf.cabal @@ -355,3 +355,52 @@ test-suite gf-tests hs-source-dirs: testsuite build-depends: base>=4.3 && <5, Cabal>=1.8, directory, filepath, process default-language: Haskell2010 + +test-suite lpgf + type: exitcode-stdio-1.0 + main-is: run.hs + hs-source-dirs: + src/compiler + src/runtime/haskell + testsuite/lpgf + build-depends: + array, + base>=4.3 && <5, + bytestring, + containers, + ghc-prim, + mtl, + pretty, + random, + utf8-string + other-modules: + Data.Binary + Data.Binary.Builder + Data.Binary.Get + Data.Binary.IEEE754 + Data.Binary.Put + LPGF + PGF + PGF.Binary + PGF.ByteCode + PGF.CId + PGF.Data + PGF.Expr + PGF.Expr + PGF.Forest + PGF.Generate + PGF.Linearize + PGF.Macros + PGF.Morphology + PGF.OldBinary + PGF.Optimize + PGF.Paraphrase + PGF.Parse + PGF.Probabilistic + PGF.Tree + PGF.TrieMap + PGF.Type + PGF.TypeCheck + PGF.Utilities + PGF.VisualizeTree + default-language: Haskell2010 diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index e07e7ba73..f3fbb9b78 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -15,7 +15,7 @@ import GF.Infra.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb, justModuleName,extendPathEnv,putStrE,putPointE) import GF.Data.Operations(raise,(+++),err) -import Control.Monad(foldM,when,(<=<),filterM,liftM) +import Control.Monad(foldM,when,(<=<),filterM) import GF.System.Directory(doesFileExist,getModificationTime) import System.FilePath((),isRelative,dropFileName) import qualified Data.Map as Map(empty,insert,elems) --lookup diff --git a/src/compiler/GF/Compile/GrammarToLPGF.hs b/src/compiler/GF/Compile/GrammarToLPGF.hs index 9bda286b0..e9f328db9 100644 --- a/src/compiler/GF/Compile/GrammarToLPGF.hs +++ b/src/compiler/GF/Compile/GrammarToLPGF.hs @@ -22,11 +22,13 @@ import qualified GF.Grammar.Macros as GM import GF.Infra.Ident import GF.Infra.Option import GF.Infra.UseIO (IOE) --- import GF.Data.Operations --- --- import Data.List +import GF.Data.Operations + +import Control.Monad (forM_) +import Data.List (elemIndex) -- import qualified Data.Set as Set import qualified Data.Map as Map +import Data.Maybe (mapMaybe) -- import qualified Data.IntMap as IntMap -- import Data.Array.IArray @@ -43,8 +45,8 @@ mkCanon2lpgf opts gr am = do -- cenv = resourceValues opts gr mkAbstr :: ModuleName -> IOE (CId, L.Abstr) - mkAbstr am = return (mi2i am, L.Abstr { L.cats = cats, L.funs = funs }) - where + mkAbstr am = do + let -- aflags = err (const noOptions) mflags (lookupModule gr am) adefs = @@ -64,17 +66,55 @@ mkCanon2lpgf opts gr am = do -- catfuns cat = -- [(0,i2i f) | ((m,f),AbsFun (Just (L _ ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat] + return (mi2i am, L.Abstr { + -- L.cats = cats, + -- L.funs = funs + }) mkConcr :: ModuleName -> IOE (CId, L.Concr) mkConcr cm = do + let - lincats = Map.fromList [] - lins = Map.fromList [] + js = fromErr [] $ do + mo <- lookupModule gr cm + -- return [((m,c),i) | (c,_) <- Map.toList (jments mo), Ok (m,i) <- [Look.lookupOrigInfo gr (cm,c)]] + return $ Map.toList (jments mo) + + -- lincats = Map.fromList [] + lins = Map.fromList $ mapMaybe mkLin js + + mkLin :: (Ident, Info) -> Maybe (CId, L.LinFun) + mkLin (i, info) = case info of + CncFun typ def@(Just (L (Local n _) term)) pn pmcfg -> do + lin <- term2lin [] Nothing term + return (i2i i, lin) + _ -> Nothing + + term2lin :: [Ident] -> Maybe Type -> Term -> Maybe L.LinFun + term2lin cxt mtype t = case t of + Abs Explicit arg term -> term2lin (arg:cxt) mtype term + C t1 t2 -> do + t1' <- term2lin cxt Nothing t1 + t2' <- term2lin cxt Nothing t2 + return $ L.LFConcat t1' t2' + K s -> Just $ L.LFToken s + Vr arg -> do + ix <- elemIndex arg (reverse cxt) + return $ L.LFArgument (ix+1) + R asgns -> do + ts <- sequence [ term2lin cxt mtype term | (_, (mtype, term)) <- asgns ] + return $ L.LFTuple ts + QC qiV -> do -- qi = ZeroEng.Sg + QC qiP <- mtype + let vs = [ ic | QC ic <- fromErr [] $ Look.lookupParamValues gr qiP ] + ix <- elemIndex qiV vs + return $ L.LFInt (ix+1) + _ -> Nothing return (mi2i cm, L.Concr { - L.lincats = lincats, - L.lins = lins - }) + -- L.lincats = lincats, + L.lins = lins + }) -- let cflags = err (const noOptions) mflags (lookupModule gr cm) -- ciCmp | flag optCaseSensitive cflags = compare diff --git a/src/runtime/haskell/LPGF.hs b/src/runtime/haskell/LPGF.hs index 595630db9..44cb1c775 100644 --- a/src/runtime/haskell/LPGF.hs +++ b/src/runtime/haskell/LPGF.hs @@ -3,11 +3,11 @@ -- "PGF: A Portable Run-Time Format for Type-Theoretical Grammars" module LPGF where -import PGF (Language, readLanguage, showLanguage) +import PGF (Language) import PGF.CId -import PGF.Tree +import PGF.Expr (Expr) +import PGF.Tree (Tree (..), expr2tree, prTree) -import Control.Monad (forM_) import qualified Data.Map as Map import Text.Printf (printf) @@ -20,13 +20,13 @@ data LPGF = LPGF { -- | Abstract syntax data Abstr = Abstr { - cats :: Map.Map CId (), - funs :: Map.Map CId Type + -- cats :: Map.Map CId (), + -- funs :: Map.Map CId Type } deriving (Read, Show) -- | Concrete syntax data Concr = Concr { - lincats :: Map.Map CId LinType, -- ^ assigning a linearization type to each category + -- lincats :: Map.Map CId LinType, -- ^ assigning a linearization type to each category lins :: Map.Map CId LinFun -- ^ assigning a linearization function to each function } deriving (Read, Show) @@ -68,7 +68,7 @@ mkConcat [x] = x mkConcat xs = foldl1 LFConcat xs -- | Main linearize function -linearize :: LPGF -> Language -> Tree -> String +linearize :: LPGF -> Language -> Expr -> String linearize lpgf lang = case Map.lookup lang (concretes lpgf) of Just concr -> linearizeConcr concr @@ -76,8 +76,8 @@ linearize lpgf lang = -- | Language-specific linearize function -- Section 2.5 -linearizeConcr :: Concr -> Tree -> String -linearizeConcr concr tree = lin2string $ lin tree +linearizeConcr :: Concr -> Expr -> String +linearizeConcr concr expr = lin2string $ lin (expr2tree expr) where lin :: Tree -> LinFun lin tree = case tree of @@ -116,75 +116,3 @@ lin2string l = case l of LFToken tok -> tok LFConcat l1 l2 -> unwords [lin2string l1, lin2string l2] x -> printf "[%s]" (show x) - ---- - -main :: IO () -main = - forM_ [tree1, tree2, tree3] $ \tree -> do - putStrLn (prTree tree) - forM_ (Map.toList (concretes zero)) $ \(lang,concr) -> - printf "%s: %s\n" (showLanguage lang) (linearizeConcr concr tree) - putStrLn "" - --- Pred John Walk -tree1 :: Tree -tree1 = Fun (mkCId "Pred") [Fun (mkCId "John") [], Fun (mkCId "Walk") []] - --- Pred We Walk -tree2 :: Tree -tree2 = Fun (mkCId "Pred") [Fun (mkCId "We") [], Fun (mkCId "Walk") []] - --- And (Pred John Walk) (Pred We Walk) -tree3 :: Tree -tree3 = Fun (mkCId "And") [tree1, tree2] - --- Initial LPGF, Figures 6 & 7 -zero :: LPGF -zero = LPGF { - absname = mkCId "Zero", - abstract = Abstr { - cats = Map.fromList [ - (mkCId "S", ()), - (mkCId "NP", ()), - (mkCId "VP", ()) - ], - funs = Map.fromList [ - (mkCId "And", Type [mkCId "S", mkCId "S"] (mkCId "S")), - (mkCId "Pred", Type [mkCId "NP", mkCId "VP"] (mkCId "S")), - (mkCId "John", Type [] (mkCId "NP")), - (mkCId "We", Type [] (mkCId "NP")), - (mkCId "Walk", Type [] (mkCId "VP")) - ] - }, - concretes = Map.fromList [ - (mkCId "ZeroEng", Concr { - lincats = Map.fromList [ - (mkCId "S", LTStr), - (mkCId "NP", LTProduct [LTStr, LTInt 2]), - (mkCId "VP", LTProduct [LTStr, LTStr]) - ], - lins = Map.fromList [ - (mkCId "And", mkConcat [LFArgument 1, LFToken "and", LFArgument 2]), - (mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFArgument 2) (LFProjection (LFArgument 1) (LFInt 2))]), - (mkCId "John", LFTuple [LFToken "John", LFInt 1]), - (mkCId "We", LFTuple [LFToken "we", LFInt 2]), - (mkCId "Walk", LFTuple [LFToken "walks", LFToken "walk"]) - ] - }), - (mkCId "ZeroGer", Concr { - lincats = Map.fromList [ - (mkCId "S", LTStr), - (mkCId "NP", LTProduct [LTStr, LTInt 2, LTInt 3]), - (mkCId "VP", LTProduct [LTProduct [LTStr, LTStr, LTStr], LTProduct [LTStr, LTStr, LTStr]]) - ], - lins = Map.fromList [ - (mkCId "And", mkConcat [LFArgument 1, LFToken "und", LFArgument 2]), - (mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFProjection (LFArgument 2) (LFProjection (LFArgument 1) (LFInt 2))) (LFProjection (LFArgument 1) (LFInt 3))]), - (mkCId "John", LFTuple [LFToken "John", LFInt 1, LFInt 3]), - (mkCId "We", LFTuple [LFToken "wir", LFInt 2, LFInt 1]), - (mkCId "Walk", LFTuple [LFTuple [LFToken "gehe", LFToken "gehst", LFToken "geht"], LFTuple [LFToken "gehen", LFToken "geht", LFToken "gehen"]]) - ] - }) - ] -} diff --git a/testsuite/lpgf/Zero.gf b/testsuite/lpgf/Zero.gf new file mode 100644 index 000000000..904572ae2 --- /dev/null +++ b/testsuite/lpgf/Zero.gf @@ -0,0 +1,12 @@ +-- From Angelov, Bringert, Ranta (2009) +abstract Zero = { + flags startcat = S ; + cat + S; NP; VP; + fun + And : S -> S -> S ; + Pred : NP -> VP -> S ; + John : NP ; + We : NP ; + Walk : VP ; +} diff --git a/testsuite/lpgf/ZeroEng.gf b/testsuite/lpgf/ZeroEng.gf new file mode 100644 index 000000000..fc97ffd9b --- /dev/null +++ b/testsuite/lpgf/ZeroEng.gf @@ -0,0 +1,19 @@ +-- From Angelov, Bringert, Ranta (2009) +concrete ZeroEng of Zero = { + lincat + S = Str ; + NP = {s : Str; n : Number} ; + VP = {s : Number => Str} ; + lin + And s1 s2 = s1 ++ "and" ++ s2 ; + Pred np vp = np.s ++ vp.s ! np.n ; + John = {s = "John"; n = Sg} ; + We = {s = "we"; n = Pl} ; + Walk = {s = table { + Sg => "walks"; + Pl => "walk" + } + } ; + param + Number = Sg | Pl ; +} diff --git a/testsuite/lpgf/ZeroGer.gf b/testsuite/lpgf/ZeroGer.gf new file mode 100644 index 000000000..5dae7560d --- /dev/null +++ b/testsuite/lpgf/ZeroGer.gf @@ -0,0 +1,28 @@ +-- From Angelov, Bringert, Ranta (2009) +concrete ZeroGer of Zero = { + lincat + S = Str ; + NP = {s : Str; n : Number; p : Person} ; + VP = {s : Number => Person => Str} ; + lin + And s1 s2 = s1 ++ "und" ++ s2 ; + Pred np vp = np.s ++ vp.s ! np.n ! np.p ; + John = {s = "John"; n = Sg ; p = P3} ; + We = {s = "wir"; n = Pl; p = P1} ; + Walk = {s = table { + Sg => table { + P1 => "gehe" ; + P2 => "gehst" ; + P3 => "geht" + } ; + Pl => table { + P1 => "gehen" ; + P2 => "geht" ; + P3 => "gehen" + } + } + } ; + param + Number = Sg | Pl ; + Person = P1 | P2 | P3 ; +} diff --git a/testsuite/lpgf/run.hs b/testsuite/lpgf/run.hs new file mode 100644 index 000000000..87ee7a770 --- /dev/null +++ b/testsuite/lpgf/run.hs @@ -0,0 +1,76 @@ +import LPGF +import PGF (Tree, mkCId, mkApp, readLanguage, showLanguage, showExpr) + +import Control.Monad (forM_) +import qualified Data.Map as Map +import Text.Printf (printf) + +main :: IO () +main = do + lpgf <- readLPGF "Zero.lpgf" + forM_ [tree1, tree2, tree3] $ \tree -> do + putStrLn (showExpr [] tree) + forM_ (Map.toList (concretes lpgf)) $ \(lang,concr) -> + printf "%s: %s\n" (showLanguage lang) (linearizeConcr concr tree) + +-- Pred John Walk +tree1 :: Tree +tree1 = mkApp (mkCId "Pred") [mkApp (mkCId "John") [], mkApp (mkCId "Walk") []] + +-- Pred We Walk +tree2 :: Tree +tree2 = mkApp (mkCId "Pred") [mkApp (mkCId "We") [], mkApp (mkCId "Walk") []] + +-- And (Pred John Walk) (Pred We Walk) +tree3 :: Tree +tree3 = mkApp (mkCId "And") [tree1, tree2] + +-- Initial LPGF, Figures 6 & 7 +zero :: LPGF +zero = LPGF { + absname = mkCId "Zero", + abstract = Abstr { + -- cats = Map.fromList [ + -- (mkCId "S", ()), + -- (mkCId "NP", ()), + -- (mkCId "VP", ()) + -- ], + -- funs = Map.fromList [ + -- (mkCId "And", Type [mkCId "S", mkCId "S"] (mkCId "S")), + -- (mkCId "Pred", Type [mkCId "NP", mkCId "VP"] (mkCId "S")), + -- (mkCId "John", Type [] (mkCId "NP")), + -- (mkCId "We", Type [] (mkCId "NP")), + -- (mkCId "Walk", Type [] (mkCId "VP")) + -- ] + }, + concretes = Map.fromList [ + (mkCId "ZeroEng", Concr { + -- lincats = Map.fromList [ + -- (mkCId "S", LTStr), + -- (mkCId "NP", LTProduct [LTStr, LTInt 2]), + -- (mkCId "VP", LTProduct [LTStr, LTStr]) + -- ], + lins = Map.fromList [ + (mkCId "And", mkConcat [LFArgument 1, LFToken "and", LFArgument 2]), + (mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFArgument 2) (LFProjection (LFArgument 1) (LFInt 2))]), + (mkCId "John", LFTuple [LFToken "John", LFInt 1]), + (mkCId "We", LFTuple [LFToken "we", LFInt 2]), + (mkCId "Walk", LFTuple [LFToken "walks", LFToken "walk"]) + ] + }), + (mkCId "ZeroGer", Concr { + -- lincats = Map.fromList [ + -- (mkCId "S", LTStr), + -- (mkCId "NP", LTProduct [LTStr, LTInt 2, LTInt 3]), + -- (mkCId "VP", LTProduct [LTProduct [LTStr, LTStr, LTStr], LTProduct [LTStr, LTStr, LTStr]]) + -- ], + lins = Map.fromList [ + (mkCId "And", mkConcat [LFArgument 1, LFToken "und", LFArgument 2]), + (mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFProjection (LFArgument 2) (LFProjection (LFArgument 1) (LFInt 2))) (LFProjection (LFArgument 1) (LFInt 3))]), + (mkCId "John", LFTuple [LFToken "John", LFInt 1, LFInt 3]), + (mkCId "We", LFTuple [LFToken "wir", LFInt 2, LFInt 1]), + (mkCId "Walk", LFTuple [LFTuple [LFToken "gehe", LFToken "gehst", LFToken "geht"], LFTuple [LFToken "gehen", LFToken "geht", LFToken "gehen"]]) + ] + }) + ] +}