summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/GF/Canon/CanonToGFCC.hs50
-rw-r--r--src/GF/Canon/GFCC/DataGFCC.hs9
-rw-r--r--src/GF/Compile/GrammarToCanon.hs15
3 files changed, 35 insertions, 39 deletions
diff --git a/src/GF/Canon/CanonToGFCC.hs b/src/GF/Canon/CanonToGFCC.hs
index 938c50621..da276bfe7 100644
--- a/src/GF/Canon/CanonToGFCC.hs
+++ b/src/GF/Canon/CanonToGFCC.hs
@@ -176,7 +176,7 @@ paramValues cgr = (labels,untyps,typs) where
]
typsFrom ty = case ty of
Table p t -> typsFrom p ++ typsFrom t
- RecType ls -> ty : concat [typsFrom t | Lbg _ t <- ls]
+ RecType ls -> RecType ls : concat [typsFrom t | Lbg _ t <- ls]
_ -> [ty]
typsFromTrm :: Term -> STM [CType] Term
@@ -210,11 +210,11 @@ term2term :: CanonGrammar -> ParamEnv -> Term -> Term
term2term cgr env@(labels,untyps,typs) tr = case tr of
Par _ _ -> mkValCase tr
R rs ->
- let
+ let
rs' = [Ass (mkLab i) (t2t t) |
- (i,Ass l t) <- zip [0..] rs, not (isLock l t)]
+ (i,Ass l t) <- zip [0..] rs] ---- , not (isLock l t)]
in if (any (isStr . trmAss) rs)
- then trace (A.prt tr) $ R rs'
+ then R rs'
else R [Ass (L (IC "_")) (mkValCase tr), Ass (L (IC "__")) (R rs')]
P t l -> r2r tr
T _ cs0 -> checkCases cs0 $
@@ -261,19 +261,6 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
_ -> error $ A.prt ty
_ -> error $ A.prt tr
updateSTM ((tyvs, (tr', tr)):)
-
-{-
- case Map.lookup (cat,lab) labels of
- Just (ty,_) -> case Map.lookup ty typs of
- Just vs -> do
- let tyvs = (ty,[t |
- (t,_) <- sortBy (\x y -> compare (snd x) (snd y))
- (Map.assocs vs)])
- updateSTM ((tyvs, (tr', tr)):)
- _ -> return ()
- _ -> return ()
--}
-
return tr'
_ -> composOp doVar tr
@@ -288,15 +275,12 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
_ -> composSafeOp (mkBranch x t) tr
mkLab k = L (IC ("_" ++ show k))
+
valNum tr = maybe (tryPerm tr) EInt $ Map.lookup tr untyps
- --- a hack needed because GFCC does not guarantee
- --- canonical order of param records
- --- complexity could be lowered by sorting the records
where
tryPerm tr = case tr of
- R rs -> case [v | Just v <-
- [Map.lookup (R rs') untyps | rs' <- permutations rs]] of
- v:_ -> EInt v
+ R rs -> case Map.lookup (R rs) untyps of
+ Just v -> EInt v
_ -> valNumFV $ tryVar tr
_ -> valNumFV $ tryVar tr
tryVar tr = case tr of
@@ -306,9 +290,6 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
valNumFV ts = case ts of
[tr] -> K (KS (A.prt tr +++ prtTrace tr "66667"))
_ -> FV $ map valNum ts
- permutations xx = case xx of
- [] -> [[]]
- _ -> [x:xs | x <- xx, xs <- permutations (xx \\ [x])]
isStr tr = case tr of
Par _ _ -> False
EInt _ -> False
@@ -330,14 +311,19 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
RecType ts -> any isStrType [t | Lbg _ t <- ts]
Table _ t -> isStrType t
_ -> False
- isLock l t = case t of --- need not look at l
- R [] -> True
- _ -> False
trmAss (Ass _ t) = t
--- this is mainly needed for parameter record projections
comp t = errVal t $ Look.ccompute cgr [] t
+-- remove lock fields; currently not done
+isLock l t = case t of --- need not look at l
+ R [] -> True
+ _ -> False
+isLockTyp l t = case t of --- need not look at l
+ RecType [] -> True
+ _ -> False
+
prtTrace tr n = n ----trace ("-- ERROR" +++ A.prt tr +++ show n +++ show tr) n
@@ -398,6 +384,7 @@ addSubexpConsts tree lins =
C.S ts -> C.S $ map (recomp f) ts
C.W s t -> C.W s (recomp f t)
C.P t p -> C.P (recomp f t) (recomp f p)
+ C.RP t p -> C.RP (recomp f t) (recomp f p)
-- C.A x t -> C.A x (recomp f t)
_ -> t
fid n = C.CId $ "_" ++ show n
@@ -418,11 +405,12 @@ collectSubterms t = case t of
C.R ts -> do
mapM collectSubterms ts
add t
+ C.RP u v -> do
+ collectSubterms v
+ add t
C.S ts -> do
mapM collectSubterms ts
add t
--- C.A x b -> do
--- collectSubterms b -- t itself can only occur once in a grammar
C.W s u -> do
collectSubterms u
add t
diff --git a/src/GF/Canon/GFCC/DataGFCC.hs b/src/GF/Canon/GFCC/DataGFCC.hs
index 09b0acbf5..8588d2f9b 100644
--- a/src/GF/Canon/GFCC/DataGFCC.hs
+++ b/src/GF/Canon/GFCC/DataGFCC.hs
@@ -97,20 +97,21 @@ compute mcfg lang args = comp where
look = lookLin mcfg lang
idx xs i =
if length xs <= i ---- debug
- then K (KS ("ERROR" ++ show xs ++ " !! " ++ show i)) else
- xs !! i
+ then trace ("ERROR in compiler producing " ++ show xs ++ " !! " ++ show i)
+ (last xs)
+ else xs !! i
getIndex t0 t = case t of
C i -> fromInteger i
RP p _ -> getIndex t0 $ p
- _ -> error $ "compiler error: index from " ++ show t
+ _ -> trace ("ERROR in compiler: index from " ++ show t) 0
---- TODO: this is workaround for a compiler bug
-- R (u : _) -> trace (show t ++ " IN\n" ++ show t0) $ getIndex t0 u
getFields t = case t of
R rs -> rs
RP _ r -> getFields r
- _ -> error $ "compiler error: fields from " ++ show t
+ _ -> trace ("ERROR in compiler: fields from " ++ show t) [t]
mkGFCC :: Grammar -> GFCC
mkGFCC (Grm (Hdr a cs) ab@(Abs funs) ccs) = GFCC {
diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs
index 089773824..e7da9281d 100644
--- a/src/GF/Compile/GrammarToCanon.hs
+++ b/src/GF/Compile/GrammarToCanon.hs
@@ -31,7 +31,7 @@ import GF.Canon.MkGFC
import qualified GF.Canon.PrintGFC as P
import Control.Monad
-import Data.List (nub)
+import Data.List (nub,sortBy)
-- compilation of optimized grammars to canonical GF. AR 5/10/2001 -- 12/5/2003
@@ -155,6 +155,13 @@ redType = redTerm
redTerm :: Type -> Err G.Exp
redTerm t = return $ rtExp t
+-- to normalize records and record types
+sortByLabel :: (a -> Label) -> [a] -> [a]
+sortByLabel f = sortBy (\ x y -> compare (f x) (f y))
+
+sortByFst :: Ord a => [(a,b)] -> [(a,b)]
+sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
+
-- resource
redParam :: Param -> Err G.ParDef
@@ -180,7 +187,7 @@ redCType t = case t of
let (ls,ts) = unzip lbs
ls' = map redLabel ls
ts' <- mapM redCType ts
- return $ G.RecType $ map (uncurry G.Lbg) $ zip ls' ts'
+ return $ G.RecType $ map (uncurry G.Lbg) $ sortByFst $ zip ls' ts'
Table p v -> liftM2 G.Table (redCType p) (redCType v)
Q m c -> liftM G.Cn $ redQIdent (m,c)
QC m c -> liftM G.Cn $ redQIdent (m,c)
@@ -208,7 +215,7 @@ redCTerm t = case t of
let (ls,tts) = unzip rs
ls' = map redLabel ls
ts <- mapM (redCTerm . snd) tts
- return $ G.R $ map (uncurry G.Ass) $ zip ls' ts
+ return $ G.R $ map (uncurry G.Ass) $ sortByFst $ zip ls' ts
RecType [] -> return $ G.R [] --- comes out in parsing
P tr l -> do
tr' <- redCTerm tr
@@ -260,7 +267,7 @@ redPatt p = case p of
let (ls,tts) = unzip rs
ls' = map redLabel ls
ts <- mapM redPatt tts
- return $ G.PR $ map (uncurry G.PAss) $ zip ls' ts
+ return $ G.PR $ map (uncurry G.PAss) $ sortByFst $ zip ls' ts
PT _ q -> redPatt q
PInt i -> return $ G.PI i
PFloat i -> return $ G.PF i
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 14:22:24 +0000