diff --git a/src/GF/Compile/BackOpt.hs b/src/GF/Compile/BackOpt.hs index 8667023c0..aeb3bcb8d 100644 --- a/src/GF/Compile/BackOpt.hs +++ b/src/GF/Compile/BackOpt.hs @@ -38,10 +38,11 @@ shareModule opt (i,m) = case m of (i,M.ModMod (M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo)))) _ -> (i,m) -shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (shareOptim opt c t)) m) -shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (shareOptim opt c t)) m) -shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (shareOptim opt c t))) -shareInfo _ i = i +shareInfo :: OptSpec -> (Ident, Info) -> Info +shareInfo opt (c, CncCat ty (Yes t) m) = CncCat ty (Yes (shareOptim opt c t)) m +shareInfo opt (c, CncFun kxs (Yes t) m) = CncFun kxs (Yes (shareOptim opt c t)) m +shareInfo opt (c, ResOper ty (Yes t)) = ResOper ty (Yes (shareOptim opt c t)) +shareInfo _ (_,i) = i -- the function putting together optimizations shareOptim :: OptSpec -> Ident -> Term -> Term diff --git a/src/GF/Compile/Coding.hs b/src/GF/Compile/Coding.hs index 89e458956..665b5916d 100644 --- a/src/GF/Compile/Coding.hs +++ b/src/GF/Compile/Coding.hs @@ -26,13 +26,12 @@ codeSourceModule co (id,moi) = case moi of ModMod mo -> (id, ModMod $ replaceJudgements mo (mapTree codj (jments mo))) _ -> (id,moi) where - codj (c,info) = (c, case info of + codj (c,info) = case info of ResOper pty pt -> ResOper (mapP codt pty) (mapP codt pt) ResOverload es tyts -> ResOverload es [(codt ty,codt t) | (ty,t) <- tyts] CncCat pty pt mpr -> CncCat pty (mapP codt pt) (mapP codt mpr) CncFun mty pt mpr -> CncFun mty (mapP codt pt) (mapP codt mpr) _ -> info - ) codt t = case t of K s -> K (co s) T ty cs -> T ty [(codp p,codt v) | (p,v) <- cs] diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs index 13f6eb9d2..bb99d9d6c 100644 --- a/src/GF/Compile/GrammarToGFCC.hs +++ b/src/GF/Compile/GrammarToGFCC.hs @@ -283,9 +283,9 @@ canon2canon abs cg0 = j2j cg (f,j) = let debug = traceD ("+ " ++ prt f) in case j of - CncFun x (Yes tr) z -> (f,CncFun x (Yes (debug (t2t tr))) z) - CncCat (Yes ty) (Yes x) y -> (f,CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y) - _ -> (f,j) + CncFun x (Yes tr) z -> CncFun x (Yes (debug (t2t tr))) z + CncCat (Yes ty) (Yes x) y -> CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y + _ -> j where cg1 = cg t2t = term2term f cg1 pv @@ -295,8 +295,8 @@ canon2canon abs cg0 = -- flatten record arguments of param constructors p2p (f,j) = case j of ResParam (Yes (ps,v)) -> - (f,ResParam (Yes ([(c,concatMap unRec cont) | (c,cont) <- ps],Nothing))) - _ -> (f,j) + ResParam (Yes ([(c,concatMap unRec cont) | (c,cont) <- ps],Nothing)) + _ -> j unRec (x,ty) = case ty of RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (identW,typ)] _ -> [(x,ty)] diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs index 05a3826bf..da18e6e3e 100644 --- a/src/GF/Compile/Optimize.hs +++ b/src/GF/Compile/Optimize.hs @@ -107,7 +107,7 @@ evalResInfo oopts gr (c,info) = case info of evalCncInfo :: - Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info) + Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err Info evalCncInfo opts gr cnc abs (c,info) = do seq (prtIf (verbAtLeast opts Verbose) c) $ return () @@ -126,7 +126,7 @@ evalCncInfo opts gr cnc abs (c,info) = do ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c) - return (c, CncCat ptyp pde' ppr') + return (CncCat ptyp pde' ppr') CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> --trace (prt c) $ eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do @@ -136,9 +136,9 @@ evalCncInfo opts gr cnc abs (c,info) = do _ -> return pde ppr' <- liftM yes $ evalPrintname gr c ppr pde' - return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed + return $ CncFun mt pde' ppr' -- only cat in type actually needed - _ -> return (c,info) + _ -> return info where pEval = partEval opts gr eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") diff --git a/src/GF/Compile/OptimizeGF.hs b/src/GF/Compile/OptimizeGF.hs index 41b828aa3..785d73994 100644 --- a/src/GF/Compile/OptimizeGF.hs +++ b/src/GF/Compile/OptimizeGF.hs @@ -51,10 +51,11 @@ processModule opt (i,m) = case m of (i,M.ModMod (M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo)))) _ -> (i,m) -shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (opt c t)) m) -shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (opt c t)) m) -shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (opt c t))) -shareInfo _ i = i +shareInfo :: (Ident -> Term -> Term) -> (Ident,Info) -> Info +shareInfo opt (c, CncCat ty (Yes t) m) = CncCat ty (Yes (opt c t)) m +shareInfo opt (c, CncFun kxs (Yes t) m) = CncFun kxs (Yes (opt c t)) m +shareInfo opt (c, ResOper ty (Yes t)) = ResOper ty (Yes (opt c t)) +shareInfo _ (_,i) = i -- the function putting together optimizations optim :: Ident -> Term -> Term diff --git a/src/GF/Compile/RemoveLiT.hs b/src/GF/Compile/RemoveLiT.hs index d06b80400..a641737eb 100644 --- a/src/GF/Compile/RemoveLiT.hs +++ b/src/GF/Compile/RemoveLiT.hs @@ -40,12 +40,12 @@ remlModule gr mi@(name,mod) = case mod of return $ (name,mod2) _ -> return mi -remlResInfo :: SourceGrammar -> (Ident,Info) -> Err (Ident,Info) -remlResInfo gr mi@(i,info) = case info of - ResOper pty ptr -> liftM ((,) i) $ liftM2 ResOper (ren pty) (ren ptr) - CncCat pty ptr ppr -> liftM ((,) i) $ liftM3 CncCat (ren pty) (ren ptr) (ren ppr) - CncFun mt ptr ppr -> liftM ((,) i) $ liftM2 (CncFun mt) (ren ptr) (ren ppr) - _ -> return mi +remlResInfo :: SourceGrammar -> (Ident,Info) -> Err Info +remlResInfo gr (i,info) = case info of + ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr) + CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr) + CncFun mt ptr ppr -> liftM2 (CncFun mt) (ren ptr) (ren ppr) + _ -> return info where ren = remlPerh gr diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs index 7b4d09277..bfa342702 100644 --- a/src/GF/Compile/Rename.hs +++ b/src/GF/Compile/Rename.hs @@ -115,15 +115,14 @@ renameIdentPatt env p = do t' <- renameIdentTerm env t term2patt t' -info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo) -info2status mq (c,i) = (c, case i of +info2status :: Maybe Ident -> (Ident,Info) -> StatusInfo +info2status mq (c,i) = case i of AbsFun _ (Yes EData) -> maybe Con QC mq ResValue _ -> maybe Con QC mq ResParam _ -> maybe Con QC mq AnyInd True m -> maybe Con (const (QC m)) mq AnyInd False m -> maybe Cn (const (Q m)) mq _ -> maybe Cn Q mq - ) tree2status :: OpenSpec Ident -> BinTree Ident Info -> BinTree Ident StatusInfo tree2status o = case o of diff --git a/src/GF/Data/Operations.hs b/src/GF/Data/Operations.hs index 253723876..9bcae5c6a 100644 --- a/src/GF/Data/Operations.hs +++ b/src/GF/Data/Operations.hs @@ -77,7 +77,8 @@ module GF.Data.Operations (-- * misc functions import Data.Char (isSpace, toUpper, isSpace, isDigit) import Data.List (nub, sortBy, sort, deleteBy, nubBy) ---import Data.FiniteMap +import qualified Data.Map as Map +import Data.Map (Map) import Control.Monad (liftM,liftM2, MonadPlus, mzero, mplus) import GF.Data.ErrM @@ -267,32 +268,22 @@ updatePerhapsHard old p1 p2 = case (p1,p2) of _ -> unifPerhaps p1 p2 -- binary search trees ---- FiniteMap implementation is slower in crucial tests -data BinTree a b = NT | BT (a,b) !(BinTree a b) !(BinTree a b) deriving (Show) --- type BinTree a b = FiniteMap a b +type BinTree a b = Map a b emptyBinTree :: BinTree a b -emptyBinTree = NT --- emptyBinTree = emptyFM +emptyBinTree = Map.empty isInBinTree :: (Ord a) => a -> BinTree a b -> Bool -isInBinTree x = err (const False) (const True) . justLookupTree x --- isInBinTree = elemFM +isInBinTree = Map.member justLookupTree :: (Monad m,Ord a) => a -> BinTree a b -> m b justLookupTree = lookupTree (const []) lookupTree :: (Monad m,Ord a) => (a -> String) -> a -> BinTree a b -> m b -lookupTree pr x tree = case tree of - NT -> fail ("no occurrence of element" +++ pr x) - BT (a,b) left right - | x < a -> lookupTree pr x left - | x > a -> lookupTree pr x right - | x == a -> return b ---lookupTree pr x tree = case lookupFM tree x of --- Just y -> return y --- _ -> fail ("no occurrence of element" +++ pr x) +lookupTree pr x tree = case Map.lookup x tree of + Just y -> return y + _ -> fail ("no occurrence of element" +++ pr x) lookupTreeMany :: Ord a => (a -> String) -> [BinTree a b] -> a -> Err b lookupTreeMany pr (t:ts) x = case lookupTree pr x t of @@ -306,60 +297,26 @@ lookupTreeManyAll pr (t:ts) x = case lookupTree pr x t of _ -> lookupTreeManyAll pr ts x lookupTreeManyAll pr [] x = [] --- | destructive update updateTree :: (Ord a) => (a,b) -> BinTree a b -> BinTree a b --- updateTree (a,b) tr = addToFM tr a b -updateTree = updateTreeGen True - --- | destructive or not -updateTreeGen :: (Ord a) => Bool -> (a,b) -> BinTree a b -> BinTree a b -updateTreeGen destr z@(x,y) tree = case tree of - NT -> BT z NT NT - BT c@(a,b) left right - | x < a -> let left' = updateTree z left in BT c left' right - | x > a -> let right' = updateTree z right in BT c left right' - | otherwise -> if destr - then BT z left right -- removing the old value of a - else tree -- retaining the old value if one exists +updateTree (a,b) = Map.insert a b buildTree :: (Ord a) => [(a,b)] -> BinTree a b -buildTree = sorted2tree . sortBy fs where - fs (x,_) (y,_) - | x < y = LT - | x > y = GT - | True = EQ --- buildTree = listToFM +buildTree = Map.fromList sorted2tree :: Ord a => [(a,b)] -> BinTree a b -sorted2tree [] = NT -sorted2tree xs = BT x (sorted2tree t1) (sorted2tree t2) where - (t1,(x:t2)) = splitAt (length xs `div` 2) xs ---sorted2tree = listToFM +sorted2tree = Map.fromAscList ---- dm less general than orig -mapTree :: ((a,b) -> (a,c)) -> BinTree a b -> BinTree a c -mapTree f NT = NT -mapTree f (BT a left right) = BT (f a) (mapTree f left) (mapTree f right) ---mapTree f = mapFM (\k v -> snd (f (k,v))) +mapTree :: ((a,b) -> c) -> BinTree a b -> BinTree a c +mapTree f = Map.mapWithKey (\k v -> f (k,v)) ---- fm less efficient than orig? -mapMTree :: (Ord a,Monad m) => ((a,b) -> m (a,c)) -> BinTree a b -> m (BinTree a c) -mapMTree f NT = return NT -mapMTree f (BT a left right) = do - a' <- f a - left' <- mapMTree f left - right' <- mapMTree f right - return $ BT a' left' right' ---mapMTree f t = liftM listToFM $ mapM f $ fmToList t +mapMTree :: (Ord a,Monad m) => ((a,b) -> m c) -> BinTree a b -> m (BinTree a c) +mapMTree f t = liftM Map.fromList $ sequence [liftM ((,) k) (f (k,x)) | (k,x) <- Map.toList t] filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b --- filterFM f t -filterBinTree f = sorted2tree . filter (uncurry f) . tree2list +filterBinTree = Map.filterWithKey tree2list :: BinTree a b -> [(a,b)] -- inorder -tree2list NT = [] -tree2list (BT z left right) = tree2list left ++ [z] ++ tree2list right ---tree2list = fmToList +tree2list = Map.toList -- parsing