Finish type passing in val2lin, generalise projection case and pass FoodsFre testsuite.

src/compiler/GF/Compile/GrammarToLPGF.hs

@@ -24,6 +24,8 @@ import Text.Printf (printf)
 
 mkCanon2lpgf :: Options -> SourceGrammar -> ModuleName -> IOE LPGF
 mkCanon2lpgf opts gr am = do
+  -- ppCanonical canon
+  -- dumpCanonical canon
   (an,abs) <- mkAbstract ab
   cncs     <- mapM mkConcrete cncs
   let lpgf = LPGF {
@@ -31,8 +33,6 @@ mkCanon2lpgf opts gr am = do
     L.abstract = abs,
     L.concretes = Map.fromList cncs
   }
-  -- ppCanonical canon
-  -- dumpCanonical canon
   -- dumpLPGF lpgf
   return lpgf
   where
@@ -54,14 +54,14 @@ mkCanon2lpgf opts gr am = do
           (lf, _) <- val2lin linValue
           return (fi2i funId, lf)
           where
-            -- Type information in return is only needed during projection, so we can be lazy about specifying it
+            -- Type information in return is only needed during projection, so we can be lazy about specifying it (hence the Nothings)
             val2lin :: C.LinValue -> Either String (L.LinFun, Maybe C.LinType)
             val2lin lv = case lv of
 
               C.ConcatValue v1 v2 -> do
                 (v1',t1) <- val2lin v1
                 (v2',t2) <- val2lin v2
-                return (L.LFConcat v1' v2', t1 <|> t2) -- surely t1 == t2
+                return (L.LFConcat v1' v2', t1 <|> t2) -- NOTE surely t1 == t2
 
               C.LiteralValue ll -> case ll of
                 C.FloatConstant f -> return (L.LFToken $ T.pack $ show f, Just C.FloatType)
@@ -105,7 +105,7 @@ mkCanon2lpgf opts gr am = do
               C.RecordValue rrvs -> do
                 let rrvs' = sortRecordRows rrvs
                 ts <- sequence [ val2lin lv | C.RecordRow lid lv <- rrvs' ]
-                return (L.LFTuple (map fst ts), Just $ C.RecordType (map (C.RecordRow undefined . fromJust . snd) ts))
+                return (L.LFTuple (map fst ts), Just $ C.RecordType (map (C.RecordRow undefined . fromJust . snd) ts)) -- TODO remove undefined
 
               C.TableValue lt trvs | isRecordType lt -> go trvs
                 where
@@ -128,9 +128,16 @@ mkCanon2lpgf opts gr am = do
               C.VariantValue (vr:_) -> val2lin vr -- NOTE variants not supported, just pick first
 
               C.VarValue (C.VarValueId (C.Unqual v)) -> do
+                -- lookup argument index
                 ix <- eitherElemIndex (C.VarId v) varIds
-                let typ = undefined -- TODO
+                -- lookup type for function
-                return (L.LFArgument (ix+1), Just typ)
+                let (C.Abstract _ _ _ funs) = ab
+                (C.Type args _) <- [ ftype | C.FunDef fid ftype <- funs, fid == funId ] `headOrLeft` printf "Cannot find type for: %s" v
+                -- lookup category for argument
+                let C.TypeBinding _ (C.Type _ (C.TypeApp catId _)) = args !! ix
+                -- lookup lintype for category
+                lt <- [ lt | C.LincatDef cid lt <- lincats, cid == catId ] `headOrLeft` printf "Cannot find type for: %s" (show catId)
+                return (L.LFArgument (ix+1), Just lt)
 
               C.PreValue pts df -> do
                 pts' <- forM pts $ \(pfxs, lv) -> do
@@ -139,27 +146,15 @@ mkCanon2lpgf opts gr am = do
                 (df', _) <- val2lin df
                 return (L.LFPre pts' df', Nothing)
 
-              -- specific case when lhs is variable into function
+              C.Projection v1 lblId -> do
-              C.Projection (C.VarValue (C.VarValueId (C.Unqual v))) lblId -> do
+                (v1', mtyp) <- val2lin v1
-                -- lookup argument index
+                -- find label index in argument type
-                argIx <- eitherElemIndex (C.VarId v) varIds
+                let Just (C.RecordType rrs) = mtyp
-                -- lookup type for function
-                let (C.Abstract _ _ _ funs) = ab
-                (C.Type args _) <- [ ftype | C.FunDef fid ftype <- funs, fid == funId ] `headOrLeft` printf "Cannot find type for: %s" v
-                -- lookup type for argument
-                let C.TypeBinding _ (C.Type _ (C.TypeApp catId _)) = args !! argIx
-                -- lookup label index in argument type
-                rrs <- [ rrs | C.LincatDef cid (C.RecordType rrs) <- lincats, cid == catId ] `headOrLeft` printf "Cannot find type for: %s" (show catId)
                 let rrs' = [ lid | C.RecordRow lid _ <- rrs ]
                 lblIx <- eitherElemIndex lblId rrs'
-
+                -- lookup lintype for record row
-                return (L.LFProjection (L.LFArgument (argIx+1)) (L.LFInt (lblIx+1)), Nothing)
+                let C.RecordRow _ lt = rrs !! lblIx
-
+                return (L.LFProjection v1' (L.LFInt (lblIx+1)), Just lt)
-              -- C.Projection v1 (C.LabelId lbl) -> do -- TODO
-              --   return L.LFEmpty
-                -- v1' <- val2lin v1
-                -- let lblIx = undefined
-                -- return $ L.LFProjection v1' (L.LFInt (lblIx+1))
 
               C.Selection v1 v2 -> do
                 (v1', t1) <- val2lin v1

testsuite/lpgf/Projection.gf

@@ -0,0 +1,8 @@
+abstract Projection = {
+  flags startcat = Comment ;
+  cat
+    Comment ; Item ;
+  fun
+    Pred : Item -> Comment ;
+    Wine : Item ;
+}

testsuite/lpgf/Projection.treebank

@@ -0,0 +1,3 @@
+Projection: Pred Wine
+ProjectionCnc: ce vin
+

testsuite/lpgf/Projection.trees

@@ -0,0 +1 @@
+Pred Wine

testsuite/lpgf/ProjectionCnc.gf

@@ -0,0 +1,20 @@
+concrete ProjectionCnc of Projection = {
+  -- param Case = Nom | Acc ;
+
+  lincat
+    Comment = {s : Str} ;
+    Item = {
+      -- s : Case => {comp : Str} ;
+      nom : {comp: Str}
+    } ;
+  lin
+    Wine = {
+      -- s = table {
+      --   Nom => {comp = "ce" ++ "vin"} ;
+      --   Acc => {comp = "ce" ++ "vin"}
+      -- } ;
+      nom = {comp = "ce" ++ "vin"} ;
+    } ;
+    -- Pred item = { s = ((item.s)!Nom).comp } ;
+    Pred item = { s = (item.nom).comp } ;
+}

testsuite/lpgf/run.hs

@@ -19,6 +19,8 @@ main = do
   doGrammar "Tables"
   doGrammar "Params"
   doGrammar "Pre"
+  doGrammar "Projection"
+
   doGrammar "Walking"
   doGrammar "Foods"
   -- doGrammar' "Foods" ["Fre"]