Correctly handle projection, but only in limited cases

src/compiler/GF/Compile/GrammarToLPGF.hs

@@ -4,20 +4,14 @@ import LPGF (LPGF (..))
 import qualified LPGF as L
 
 import PGF.CId
--- import GF.Grammar.Predef
 import GF.Grammar.Grammar
--- import qualified GF.Grammar.Lookup as Look
--- import qualified GF.Grammar as A
--- import qualified GF.Grammar.Macros as GM
 import qualified GF.Grammar.Canonical as C
 import GF.Compile.GrammarToCanonical (grammar2canonical)
 
-import GF.Infra.Ident
 import GF.Infra.Option
 import GF.Infra.UseIO (IOE)
--- import GF.Data.Operations
 
--- import Control.Monad (forM_)
+import Control.Monad (unless)
 import Data.Either (lefts, rights)
 import Data.List (elemIndex)
 import qualified Data.Map as Map
@@ -26,7 +20,6 @@ import Text.Printf (printf)
 
 mkCanon2lpgf :: Options -> SourceGrammar -> ModuleName -> IOE LPGF
 mkCanon2lpgf opts gr am = do
-  let grcn@(C.Grammar ab cncs) = grammar2canonical opts am gr
   (an,abs) <- mkAbstr ab
   cncs     <- mapM mkConcr cncs
   let lpgf = LPGF {
@@ -34,100 +27,107 @@ mkCanon2lpgf opts gr am = do
     L.abstract = abs,
     L.concretes = Map.fromList cncs
   }
-  print lpgf
+  -- print lpgf
   return lpgf
   where
+    C.Grammar ab cncs = grammar2canonical opts am gr
+
     mkAbstr :: C.Abstract -> IOE (CId, L.Abstr)
     mkAbstr (C.Abstract modId flags cats funs) = return (mdi2i modId, L.Abstr {})
 
     mkConcr :: C.Concrete -> IOE (CId, L.Concr)
     mkConcr (C.Concrete modId absModId flags params lincats lindefs) = do
-      -- print modId
-      -- print absModId
-      -- print flags
-      -- print params
-      -- print lincats
-      -- print lindefs
-
       let
         es = map mkLin lindefs
         lins = Map.fromList $ rights es
 
         mkLin :: C.LinDef -> Either String (CId, L.LinFun)
-        mkLin ld@(C.LinDef funId varIds linValue) = do
+        mkLin (C.LinDef funId varIds linValue) = do
-          lf <- val2lin varIds linValue
+          lf <- val2lin linValue
           return (fi2i funId, lf)
+          where
+            val2lin :: C.LinValue -> Either String L.LinFun
+            val2lin lv = case lv of
 
-        val2lin :: [C.VarId] -> C.LinValue -> Either String L.LinFun
+              C.ConcatValue v1 v2 -> do
-        val2lin vids lv = case lv of
+                v1' <- val2lin v1
+                v2' <- val2lin v2
+                return $ L.LFConcat v1' v2'
 
-          C.ConcatValue v1 v2 -> do
+              C.LiteralValue ll -> case ll of
-            v1' <- val2lin vids v1
+                C.FloatConstant f -> return $ L.LFToken (show f)
-            v2' <- val2lin vids v2
+                C.IntConstant i -> return $ L.LFToken (show i) -- LFInt i ?
-            return $ L.LFConcat v1' v2'
+                C.StrConstant s -> return $ L.LFToken s
 
-          C.LiteralValue ll -> case ll of
+              C.ErrorValue err -> return $ L.LFError err
-            C.FloatConstant f -> return $ L.LFToken (show f)
-            C.IntConstant i -> return $ L.LFToken (show i) -- LFInt ?
-            C.StrConstant s -> return $ L.LFToken s
 
-          C.ErrorValue err -> return $ L.LFError err
+              C.ParamConstant p@(C.Param (C.ParamId (C.Qual _ _)) _) -> do
+                let
+                  mixs =
+                    [ elemIndex p pvs
+                    | C.ParamDef pid pvds <- params
+                    , let pvs = map (\(C.Param pid []) -> C.Param pid []) pvds -- TODO assumption of [] probably wrong
+                    ] -- look in all paramdefs
+                case catMaybes mixs of
+                  ix:_ -> return $ L.LFInt (ix+1)
+                  _ -> Left $ printf "Cannot find param value: %s" (show p)
 
-          C.ParamConstant p@(C.Param (C.ParamId (C.Qual _ _)) _) -> do
+              -- PredefValue PredefId -- TODO predef not supported
-            let
-              mixs =
-                [ elemIndex p pvs
-                | C.ParamDef pid pvds <- params
-                , let pvs = map (\(C.Param pid []) -> C.Param pid []) pvds -- TODO assumption of [] probably wrong
-                ] -- look in all paramdefs
-            case catMaybes mixs of
-              ix:_ -> return $ L.LFInt (ix+1)
-              _ -> Left $ printf "Cannot find param value: %s" (show p)
 
-          -- PredefValue PredefId -- TODO predef not supported
+              C.RecordValue rrvs -> do
+                ts <- sequence [ val2lin lv | C.RecordRow lid lv <- rrvs ]
+                return $ L.LFTuple ts
 
-          C.RecordValue rrvs -> do
+              C.TableValue lt trvs -> do
-            ts <- sequence [ val2lin vids lv | C.RecordRow lid lv <- rrvs ]
+                ts <- sequence [ val2lin lv | C.TableRow lpatt lv <- trvs ] -- TODO variables in lhs
-            return $ L.LFTuple ts
+                return $ L.LFTuple ts
 
-          C.TableValue lt trvs -> do
+              C.TupleValue lvs -> do
-            ts <- sequence [ val2lin vids lv | C.TableRow lpatt lv <- trvs ] -- TODO variables in lhs
+                ts <- mapM val2lin lvs
-            return $ L.LFTuple ts
+                return $ L.LFTuple ts
 
-          C.TupleValue lvs -> do
+              C.VariantValue [] -> return L.LFEmpty
-            ts <- mapM (val2lin vids) lvs
+              C.VariantValue (vr:_) -> val2lin vr -- TODO variants not supported, just pick first
-            return $ L.LFTuple ts
 
-          C.VariantValue [] -> return L.LFEmpty
+              C.VarValue (C.VarValueId (C.Unqual v)) -> do
-          C.VariantValue (vr:_) -> val2lin vids vr -- TODO variants not supported, just pick first
+                ix <- eitherElemIndex (C.VarId v) varIds
+                return $ L.LFArgument (ix+1)
 
-          C.VarValue (C.VarValueId (C.Unqual v)) -> do
+              -- PreValue [([String], LinValue)] LinValue -- TODO pre not supported
-            ix <- eitherElemIndex (C.VarId v) vids
-            return $ L.LFArgument (ix+1)
 
-          -- PreValue [([String], LinValue)] LinValue -- TODO pre not supported
+              -- specific case when lhs is variable into function
+              C.Projection (C.VarValue (C.VarValueId (C.Unqual v))) lblId -> do
+                -- lookup argument index
+                argIx <- eitherElemIndex (C.VarId v) varIds
+                -- lookup type for function
+                let (C.Abstract _ _ _ funs) = ab
+                (C.Type args _) <- case [ ftype | C.FunDef fid ftype <- funs, fid == funId ] of t:_ -> Right t ; _ -> Left $ 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 <- case [ rrs | C.LincatDef cid (C.RecordType rrs) <- lincats, cid == catId ] of t:_ -> Right t ; _ -> Left $ printf "Cannot find type for: %s" (show catId)
+                let rrs' = [ lid | C.RecordRow lid _ <- rrs ]
+                lblIx <- eitherElemIndex lblId rrs'
 
-          C.Projection v1 (C.LabelId lbl) -> do
+                return $ L.LFProjection (L.LFArgument (argIx+1)) (L.LFInt (lblIx+1))
-            v1' <- val2lin vids v1
-            let lblIx = case lbl of -- TODO
-                  "s" -> 0
-                  "n" -> 1
-                  "p" -> 2
-            return $ L.LFProjection v1' (L.LFInt (lblIx+1))
 
-          C.Selection v1 v2 -> do
+              -- C.Projection v1 (C.LabelId lbl) -> do -- TODO how to handle general case?
-            v1' <- val2lin vids v1
+                -- v1' <- val2lin v1
-            v2' <- val2lin vids v2
+                -- let lblIx = undefined
-            return $ L.LFProjection v1' v2'
+                -- return $ L.LFProjection v1' (L.LFInt (lblIx+1))
 
-          C.CommentedValue cmnt lv -> val2lin vids lv
+              C.Selection v1 v2 -> do
+                v1' <- val2lin v1
+                v2' <- val2lin v2
+                return $ L.LFProjection v1' v2'
 
-          v -> Left $ printf "val2lin not implemented for: %s" (show v)
+              C.CommentedValue cmnt lv -> val2lin lv
 
-      mapM_ putStrLn (lefts es)
+              v -> Left $ printf "val2lin not implemented for: %s" (show v)
+
+      unless (null $ lefts es) (error $ unlines (lefts es))
 
       return (mdi2i modId, L.Concr {
-        -- L.lincats = lincats,
         L.lins = lins
       })
 
@@ -136,12 +136,6 @@ eitherElemIndex x xs = case elemIndex x xs of
   Just ix -> Right ix
   Nothing -> Left $ printf "Cannot find: %s" (show x)
 
-i2i :: Ident -> CId
-i2i = utf8CId . ident2utf8
-
-mi2i :: ModuleName -> CId
-mi2i (MN i) = i2i i
-
 mdi2i :: C.ModId -> CId
 mdi2i (C.ModId i) = mkCId i