forked from GitHub/gf-core
sort records so that s field is first (use Macros.sortRec)
This commit is contained in:
@@ -370,7 +370,7 @@ computeLType gr t = do
|
|||||||
_ -> return $ ExtR r' s'
|
_ -> return $ ExtR r' s'
|
||||||
|
|
||||||
RecType fs -> do
|
RecType fs -> do
|
||||||
let fs' = sortBy (\x y -> compare (fst x) (fst y)) fs
|
let fs' = sortRec fs
|
||||||
liftM RecType $ mapPairsM comp fs'
|
liftM RecType $ mapPairsM comp fs'
|
||||||
|
|
||||||
_ | ty == typeTok -> return typeStr
|
_ | 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
|
RecType ts -> maybe (error ("label index" +++ prt lab)) id $ lookup lab $ labs ts
|
||||||
_ -> error $ "label index" +++ prt ty
|
_ -> error $ "label index" +++ prt ty
|
||||||
where
|
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
|
-- 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
|
vfs' -> case [(v,f) | (v,f) <- vfs', noProd v] of
|
||||||
[(val,fun)] -> do
|
[(val,fun)] -> do
|
||||||
checkWarn $ "WARNING: overloading of" +++ prt f +++
|
|
||||||
"resolved by excluding partial applications:" ++++
|
----- unsafely exclude irritating warning AR 24/5/2008
|
||||||
unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)]
|
----- 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)
|
return (mkApp fun tts, val)
|
||||||
|
|
||||||
_ -> raise $ "ambiguous overloading of" +++ prt f +++
|
_ -> raise $ "ambiguous overloading of" +++ prt f +++
|
||||||
|
|||||||
@@ -399,7 +399,7 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
|
|||||||
App _ _ -> mkValCase (unrec tr)
|
App _ _ -> mkValCase (unrec tr)
|
||||||
QC _ _ -> mkValCase tr
|
QC _ _ -> mkValCase tr
|
||||||
R rs -> R [(mkLab i, (Nothing, t2t t)) |
|
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
|
P t l -> r2r tr
|
||||||
PI t l i -> EInt $ toInteger i
|
PI t l i -> EInt $ toInteger i
|
||||||
|
|
||||||
@@ -529,7 +529,7 @@ notlock (l, t) = case t of --- need not look at l
|
|||||||
_ -> True
|
_ -> True
|
||||||
|
|
||||||
unlockTy ty = case ty of
|
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
|
_ -> GM.composSafeOp unlockTy ty
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@@ -28,6 +28,7 @@ import GF.Grammar.PrGrammar
|
|||||||
|
|
||||||
import Control.Monad (liftM, liftM2)
|
import Control.Monad (liftM, liftM2)
|
||||||
import Data.Char (isDigit)
|
import Data.Char (isDigit)
|
||||||
|
import Data.List (sortBy)
|
||||||
|
|
||||||
firstTypeForm :: Type -> Err (Context, Type)
|
firstTypeForm :: Type -> Err (Context, Type)
|
||||||
firstTypeForm t = case t of
|
firstTypeForm t = case t of
|
||||||
@@ -719,3 +720,14 @@ isInOneType t = case t of
|
|||||||
Prod _ a b -> a == b
|
Prod _ a b -> a == b
|
||||||
_ -> False
|
_ -> 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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user