diff options
Diffstat (limited to 'src/GF/Compile')
| -rw-r--r-- | src/GF/Compile/CheckGrammar.hs | 2 | ||||
| -rw-r--r-- | src/GF/Compile/Compute.hs | 25 | ||||
| -rw-r--r-- | src/GF/Compile/GrammarToGFCC.hs | 20 |
3 files changed, 18 insertions, 29 deletions
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 |