Strip down format. More early work on compiler. Add testsuite (doesn't work yet).

.gitignore

@@ -5,6 +5,7 @@
 *.jar
 *.gfo
 *.pgf
+*.lpgf
 debian/.debhelper
 debian/debhelper-build-stamp
 debian/gf

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

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

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

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"]])
-      ]
-    })
-  ]
-}

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 ;
+}

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 ;
+}

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 ;
+}

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"]])
+      ]
+    })
+  ]
+}