diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index c93788cd2..5b9e6d923 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -455,7 +455,7 @@ inferLType gr trm = case trm of prtFail "cannot infer type of canonical constant" trm ] - Val ty i -> termWith trm $ return ty + Val _ ty i -> termWith trm $ return ty Vr ident -> termWith trm $ checkLookup ident diff --git a/src/GF/Compile/Compute.hs b/src/GF/Compile/Compute.hs index 3c7c061fc..a33522829 100644 --- a/src/GF/Compile/Compute.hs +++ b/src/GF/Compile/Compute.hs @@ -309,14 +309,21 @@ computeTermOpt rec gr = comput True where T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c -- course-of-values table: look up by index, no pattern matching needed - V ptyp ts -> do - vs <- allParamValues gr ptyp - case lookupR v' (zip vs [0 .. length vs - 1]) of - Just i -> comp g $ ts !! i - _ -> return $ S t' v' -- if v' is not canonical - T _ cc -> case matchPattern cc v' of + + V ptyp ts -> case v' of + Val _ _ i -> comp g $ ts !! i + _ -> do + vs <- allParamValues gr ptyp + case lookupR v' (zip vs [0 .. length vs - 1]) of + Just i -> comp g $ ts !! i + _ -> return $ S t' v' -- if v' is not canonical + T _ cc -> do + let v2 = case v' of + Val te _ _ -> te + _ -> v' + case matchPattern cc v2 of Ok (c,g') -> comp (g' ++ g) c - _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t + _ | isCan v2 -> prtBad ("missing case" +++ prt v2 +++ "in") t _ -> return $ S t' v' -- if v' is not canonical S (T i cs) e -> prawitz g i (flip S v') cs e @@ -348,8 +355,8 @@ computeTermOpt rec gr = comput True where pty0 <- getTableType i ptyp <- comp g pty0 case allParamValues gr ptyp of - Ok vs -> do - + Ok vs0 -> do + let vs = [Val v ptyp i | (v,i) <- zip vs0 [0..]] ps0 <- mapM (compPatternMacro . fst) cs cs' <- mapM (compBranchOpt g) (zip ps0 (map snd cs)) sts <- mapM (matchPattern cs') vs diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs index 539e5834c..27081ec94 100644 --- a/src/GF/Compile/GrammarToGFCC.hs +++ b/src/GF/Compile/GrammarToGFCC.hs @@ -445,25 +445,6 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of --- this is mainly needed for parameter record projections ---- was: comp t = errVal t $ Compute.computeConcreteRec cgr t - compt t = case t of - T (TComp typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should... - T (TTyped typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should - V typ ts -> V typ (map comp ts) - S tb (FV ts) -> FV $ map (comp . S tb) ts - S tb@(V typ ts) v0 -> err error id $ do - let v = comp v0 - let mv1 = Map.lookup v untyps - case mv1 of - Just v0 -> - let v1 = fromInteger v0 - v2 = v1 --if length ts > v1 then v1 - --else trace ("DEBUG" +++ show v1 +++ "of" +++ show ts) 0 - in return $ (comp . (ts !!)) v2 - _ -> return (S (comp tb) v) - - R r -> R [(l,(ty,comp t)) | (l,(ty,t)) <- r] - P (R r) l -> maybe t (comp . snd) $ lookup l r - _ -> GM.composSafeOp comp t doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term doVar tr = case getLab tr of @@ -511,6 +492,7 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of _ | tr == x -> t _ -> GM.composSafeOp (mkBranch x t) tr + valNum (Val _ _ i) = EInt $ toInteger i valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps where tryFV tr = case GM.appForm tr of diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs index 5259e5618..a3735c32f 100644 --- a/src/GF/Grammar/Grammar.hs +++ b/src/GF/Grammar/Grammar.hs @@ -156,7 +156,7 @@ data Term = | TSh TInfo [Cases] -- ^ table with disjunctive patters (only back end opt) | V Type [Term] -- ^ table given as course of values: @table T [c1 ; ... ; cn]@ | S Term Term -- ^ selection: @t ! p@ - | Val Type Int -- ^ parameter value number: @T # i# + | Val Term Type Int -- ^ parameter value number: @T # i# | Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@ @@ -194,7 +194,7 @@ data Patt = | PFloat Double -- ^ float literal pattern: @1.2@ -- only abstract | PT Type Patt -- ^ type-annotated pattern - | PVal Type Int -- ^ parameter value number: @T # i# + | PVal Patt Type Int -- ^ parameter value number: @T # i# | PAs Ident Patt -- ^ as-pattern: x@p diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs index b8c6a2a19..4a11a0d3f 100644 --- a/src/GF/Grammar/Lookup.hs +++ b/src/GF/Grammar/Lookup.hs @@ -178,7 +178,7 @@ lookupValueIndex :: SourceGrammar -> Type -> Term -> Err Term lookupValueIndex gr ty tr = do ts <- allParamValues gr ty case lookup tr $ zip ts [0..] of - Just i -> return $ Val ty i + Just i -> return $ Val tr ty i _ -> Bad $ "no index for" +++ prt tr +++ "in" +++ prt ty lookupIndexValue :: SourceGrammar -> Type -> Int -> Err Term diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs index be03c02a7..065dcef60 100644 --- a/src/GF/Grammar/Macros.hs +++ b/src/GF/Grammar/Macros.hs @@ -437,7 +437,9 @@ linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s} term2patt :: Term -> Err Patt term2patt trm = case termForm trm of Ok ([], Vr x, []) -> return (PV x) - Ok ([], Val ty x, []) -> return (PVal ty x) + Ok ([], Val te ty x, []) -> do + te' <- term2patt te + return (PVal te' ty x) Ok ([], Con c, aa) -> do aa' <- mapM term2patt aa return (PC c aa') @@ -488,7 +490,7 @@ patt2term :: Patt -> Term patt2term pt = case pt of PV x -> Vr x PW -> Vr identW --- not parsable, should not occur - PVal t i -> Val t i + PVal v t i -> Val (patt2term v) t i PMacro c -> Cn c PM p c -> Q p c @@ -623,9 +625,10 @@ composOp co trm = vs' <- mapM co vs return (V ty' vs') - Val ty i -> - do ty' <- co ty - return (Val ty' i) + Val te ty i -> + do te' <- co te + ty' <- co ty + return (Val te' ty' i) Let (x,(mt,a)) b -> do a' <- co a diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs index 92d75f2d3..e576dc12e 100644 --- a/src/GF/Grammar/PatternMatch.hs +++ b/src/GF/Grammar/PatternMatch.hs @@ -75,9 +75,11 @@ tryMatch (p,t) = do isInConstantFormt = True -- tested already in matchPattern trym p t' = case (p,t') of - (PVal _ i, (_,Val _ j,_)) + (PVal _ _ i, (_,Val _ _ j,_)) | i == j -> return [] | otherwise -> Bad $ "no match of values" + (PVal pa _ _,_) -> trym pa t' + (_, (_,Val te _ _,_)) -> tryMatch (p, te) (_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = [] (PV IW, _) | isInConstantFormt -> return [] -- optimization with wildcard (PV x, _) | isInConstantFormt -> return [(x,t)] @@ -151,6 +153,7 @@ isInConstantForm trm = case trm of Empty -> True Alias _ _ t -> isInConstantForm t EInt _ -> True + Val _ _ _ -> True _ -> False ---- isInArgVarForm trm varsOfPatt :: Patt -> [Ident] diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs index fa879cf23..73b0feafd 100644 --- a/src/GF/Source/GrammarToSource.hs +++ b/src/GF/Source/GrammarToSource.hs @@ -201,6 +201,7 @@ trt trm = case trm of FV ts -> P.EVariants $ map trt ts Strs tt -> P.EStrs $ map trt tt EData -> P.EData + Val te _ _ -> trt te ---- _ -> error $ "not yet" +++ show trm ---- trp :: Patt -> P.Patt @@ -228,6 +229,7 @@ trp p = case p of PChars s -> P.PChars s PM m c -> P.PM (tri m) (tri c) + PVal p _ _ -> trp p ---- trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty where