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

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