From 2a5850023b6182ecbac7747936113980681c824b Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Mon, 1 Feb 2021 13:08:39 +0100 Subject: [PATCH] Correctly handle projection, but only in limited cases --- src/compiler/GF/Compile/GrammarToLPGF.hs | 146 +++++++++++------------ 1 file changed, 70 insertions(+), 76 deletions(-) diff --git a/src/compiler/GF/Compile/GrammarToLPGF.hs b/src/compiler/GF/Compile/GrammarToLPGF.hs index 54b449dfe..a4b2840ae 100644 --- a/src/compiler/GF/Compile/GrammarToLPGF.hs +++ b/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 - lf <- val2lin varIds linValue + mkLin (C.LinDef funId varIds linValue) = do + 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 - val2lin vids lv = case lv of + C.ConcatValue v1 v2 -> do + v1' <- val2lin v1 + v2' <- val2lin v2 + return $ L.LFConcat v1' v2' - C.ConcatValue v1 v2 -> do - v1' <- val2lin vids v1 - v2' <- val2lin vids v2 - return $ L.LFConcat v1' v2' + C.LiteralValue ll -> case ll of + C.FloatConstant f -> return $ L.LFToken (show f) + C.IntConstant i -> return $ L.LFToken (show i) -- LFInt i ? + C.StrConstant s -> return $ L.LFToken s - C.LiteralValue ll -> case ll of - 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.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 - 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 - -- 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 - ts <- sequence [ val2lin vids lv | C.RecordRow lid lv <- rrvs ] - return $ L.LFTuple ts + C.TableValue lt trvs -> do + ts <- sequence [ val2lin lv | C.TableRow lpatt lv <- trvs ] -- TODO variables in lhs + return $ L.LFTuple ts - C.TableValue lt trvs -> do - ts <- sequence [ val2lin vids lv | C.TableRow lpatt lv <- trvs ] -- TODO variables in lhs - return $ L.LFTuple ts + C.TupleValue lvs -> do + ts <- mapM val2lin lvs + return $ L.LFTuple ts - C.TupleValue lvs -> do - ts <- mapM (val2lin vids) lvs - return $ L.LFTuple ts + C.VariantValue [] -> return L.LFEmpty + C.VariantValue (vr:_) -> val2lin vr -- TODO variants not supported, just pick first - C.VariantValue [] -> return L.LFEmpty - C.VariantValue (vr:_) -> val2lin vids vr -- TODO variants not supported, just pick first + C.VarValue (C.VarValueId (C.Unqual v)) -> do + ix <- eitherElemIndex (C.VarId v) varIds + return $ L.LFArgument (ix+1) - C.VarValue (C.VarValueId (C.Unqual v)) -> do - ix <- eitherElemIndex (C.VarId v) vids - return $ L.LFArgument (ix+1) + -- PreValue [([String], LinValue)] LinValue -- TODO pre not supported - -- 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 - v1' <- val2lin vids v1 - let lblIx = case lbl of -- TODO - "s" -> 0 - "n" -> 1 - "p" -> 2 - return $ L.LFProjection v1' (L.LFInt (lblIx+1)) + return $ L.LFProjection (L.LFArgument (argIx+1)) (L.LFInt (lblIx+1)) - C.Selection v1 v2 -> do - v1' <- val2lin vids v1 - v2' <- val2lin vids v2 - return $ L.LFProjection v1' v2' + -- C.Projection v1 (C.LabelId lbl) -> do -- TODO how to handle general case? + -- v1' <- val2lin v1 + -- let lblIx = undefined + -- 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