diff --git a/src-3.0/GF/Compile/CheckGrammar.hs b/src-3.0/GF/Compile/CheckGrammar.hs index 5e581cce2..9982aaf24 100644 --- a/src-3.0/GF/Compile/CheckGrammar.hs +++ b/src-3.0/GF/Compile/CheckGrammar.hs @@ -370,7 +370,7 @@ computeLType gr t = do _ -> return $ ExtR r' s' RecType fs -> do - let fs' = sortBy (\x y -> compare (fst x) (fst y)) fs + let fs' = sortRec fs liftM RecType $ mapPairsM comp fs' _ | ty == typeTok -> return typeStr @@ -395,7 +395,7 @@ labelIndex ty lab = case ty of RecType ts -> maybe (error ("label index" +++ prt lab)) id $ lookup lab $ labs ts _ -> error $ "label index" +++ prt ty where - labs ts = zip (map fst (sortBy (\ x y -> compare (fst x) (fst y)) ts)) [0..] + labs ts = zip (map fst (sortRec ts)) [0..] -- the underlying algorithms @@ -667,9 +667,12 @@ getOverload env@gr mt t = case appForm t of vfs' -> case [(v,f) | (v,f) <- vfs', noProd v] of [(val,fun)] -> do - checkWarn $ "WARNING: overloading of" +++ prt f +++ - "resolved by excluding partial applications:" ++++ - unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)] + +----- unsafely exclude irritating warning AR 24/5/2008 +----- checkWarn $ "WARNING: overloading of" +++ prt f +++ +----- "resolved by excluding partial applications:" ++++ +----- unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)] + return (mkApp fun tts, val) _ -> raise $ "ambiguous overloading of" +++ prt f +++ diff --git a/src-3.0/GF/Compile/GrammarToGFCC.hs b/src-3.0/GF/Compile/GrammarToGFCC.hs index 928180973..2aad8bb05 100644 --- a/src-3.0/GF/Compile/GrammarToGFCC.hs +++ b/src-3.0/GF/Compile/GrammarToGFCC.hs @@ -399,7 +399,7 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of App _ _ -> mkValCase (unrec tr) QC _ _ -> mkValCase tr R rs -> R [(mkLab i, (Nothing, t2t t)) | - (i,(l,(_,t))) <- zip [0..] (sort (unlock rs))] + (i,(l,(_,t))) <- zip [0..] (GM.sortRec (unlock rs))] P t l -> r2r tr PI t l i -> EInt $ toInteger i @@ -529,7 +529,7 @@ notlock (l, t) = case t of --- need not look at l _ -> True unlockTy ty = case ty of - RecType ls -> RecType $ sort [(l, unlockTy t) | (l,t) <- ls, notlock (l,t)] + RecType ls -> RecType $ GM.sortRec [(l, unlockTy t) | (l,t) <- ls, notlock (l,t)] _ -> GM.composSafeOp unlockTy ty diff --git a/src-3.0/GF/Grammar/Macros.hs b/src-3.0/GF/Grammar/Macros.hs index f6543ea6c..be03c02a7 100644 --- a/src-3.0/GF/Grammar/Macros.hs +++ b/src-3.0/GF/Grammar/Macros.hs @@ -28,6 +28,7 @@ import GF.Grammar.PrGrammar import Control.Monad (liftM, liftM2) import Data.Char (isDigit) +import Data.List (sortBy) firstTypeForm :: Type -> Err (Context, Type) firstTypeForm t = case t of @@ -719,3 +720,14 @@ isInOneType t = case t of Prod _ a b -> a == b _ -> False +-- normalize records and record types; put s first + +sortRec :: [(Label,a)] -> [(Label,a)] +sortRec = sortBy ordLabel where + ordLabel (r1,_) (r2,_) = case (prt r1, prt r2) of + ("s",_) -> LT + (_,"s") -> GT + (s1,s2) -> compare s1 s2 + + +