diff options
Diffstat (limited to 'src/compiler/GF/Compile')
| -rw-r--r-- | src/compiler/GF/Compile/Compute/ConcreteLazy.hs | 531 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Compute/ConcreteStrict.hs | 494 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Refresh.hs | 153 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/SubExOpt.hs | 56 |
4 files changed, 28 insertions, 1206 deletions
diff --git a/src/compiler/GF/Compile/Compute/ConcreteLazy.hs b/src/compiler/GF/Compile/Compute/ConcreteLazy.hs deleted file mode 100644 index 929e30ce1..000000000 --- a/src/compiler/GF/Compile/Compute/ConcreteLazy.hs +++ /dev/null @@ -1,531 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Compile.Concrete.Compute --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/01 15:39:12 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.19 $ --- --- Computation of source terms. Used in compilation and in @cc@ command. ------------------------------------------------------------------------------ - -module GF.Compile.Compute.ConcreteLazy ({-computeConcrete, computeTerm,checkPredefError-}) where -{- -import GF.Grammar.Grammar -import GF.Data.Operations -import GF.Infra.Ident ---import GF.Infra.Option -import GF.Data.Str ---import GF.Grammar.ShowTerm -import GF.Grammar.Printer -import GF.Grammar.Predef -import GF.Grammar.Macros -import GF.Grammar.Lookup ---import GF.Compile.Refresh -import GF.Grammar.PatternMatch -import GF.Grammar.Lockfield (isLockLabel,unlockRecord) ---- - -import GF.Compile.Compute.AppPredefined - -import Data.List (nub) --intersperse ---import Control.Monad (liftM2, liftM) -import Control.Monad.Identity -import GF.Text.Pretty - -----import Debug.Trace - ---type Comp a = Err a -- makes computations (hyper)strict ---errr = id - -type Comp a = Identity a -- inherit Haskell's laziness -errr = err runtime_error return -- convert interpreter error to run-time error -no_error = err fail return -- failure caused by interpreter/type checker bug (?) -runtime_error = return . Error -- run-time error term - --- | computation of concrete syntax terms into normal form --- used mainly for partial evaluation -computeConcrete :: SourceGrammar -> Term -> Err Term -computeConcrete g t = {- refreshTerm t >>= -} computeTerm g [] t - -computeTerm :: SourceGrammar -> Substitution -> Term -> Err Term -computeTerm gr g = return . runIdentity . computeTermOpt gr g - -computeTermOpt :: SourceGrammar -> Substitution -> Term -> Comp Term -computeTermOpt gr = comput True where - - -- full = True means full evaluation under Abs - comput full g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging - --trace ("comput "++show (map fst g)++" "++take 65 (show t)) $ - case t of - - Q (p,c) | p == cPredef -> return t -- qualified constant - | otherwise -> look (p,c) - - Vr x -> do -- local variable - t' <- maybe (fail (render (text "no value given to variable" <+> ppIdent x))) - return $ lookup x g - case t' of - _ | t == t' -> return t - _ -> comp g t' --- why compute again? AR 25/8/2011 - - -- Abs x@(IA _) b -> do - Abs _ _ _ | full -> do -- \xs -> b - let (xs,b1) = termFormCnc t - b' <- comp ([(x,Vr x) | (_,x) <- xs] ++ g) b1 - return $ mkAbs xs b' - -- b' <- comp (ext x (Vr x) g) b - -- return $ Abs x b' - Abs _ _ _ -> return t -- hnf - - Let (x,(ty,a)) b -> do -- let x : ty = a in b - a' <- comp g a - comp (ext x a' g) b - -{- -- trying to prevent Let expansion with non-evaluated exps. AR 19/8/2011 - Let (x,(ty,a)) b -> do - a' <- comp g a - let ea' = checkNoArgVars a' - case ea' of - Ok v -> comp (ext x v g) b - _ -> return $ Let (x,(ty,a')) b --} - - Prod b x a t -> do -- (x : a) -> t ; b for hiding - a' <- comp g a - t' <- comp (ext x (Vr x) g) t - return $ Prod b x a' t' - - -- beta-convert: simultaneous for as many arguments as possible - App f a -> case appForm t of -- (f a) --> (h as) - (h,as) | length as > 1 -> do - h' <- hnf g h - as' <- mapM (comp g) as - case h' of - Error{} -> return h' - _ | not (null [() | FV _ <- as']) -> compApp g (mkApp h' as') - c@(QC _) -> do - return $ mkApp c as' - Q (mod,f) | mod == cPredef -> - case appPredefined (mkApp h' as') of - Ok (t',b) -> if b then return t' else comp g t' - Bad s -> runtime_error s - - Abs _ _ _ -> do - let (xs,b) = termFormCnc h' - let g' = (zip (map snd xs) as') ++ g - let as2 = drop (length xs) as' - let xs2 = drop (length as') xs - b' <- comp g' (mkAbs xs2 b) - if null as2 then return b' else comp g (mkApp b' as2) - - _ -> compApp g (mkApp h' as') - _ -> compApp g t - - P t l | isLockLabel l -> return $ R [] -- t.lock_C - ---- a workaround 18/2/2005: take this away and find the reason - ---- why earlier compilation destroys the lock field - - - P t l -> do -- t.l - t' <- comp g t - case t' of - Error{} -> return t' - FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants -- (r| r').l - R r -> project l r --{...}.l - - ExtR a (R b) -> -- (a ** {...}).l - maybe (comp g (P a l)) (comp g) (try_project l b) - ---- { - --- this is incorrect, since b can contain the proper value - ExtR (R a) b -> -- NOT POSSIBLE both a and b records! - maybe (comp g (P b l)) (comp g) (try_project l a) ---- - } --- - - S (T i cs) e -> prawitz g i (flip P l) cs e -- ((table i branches) ! e).l - S (V i cs) e -> prawitzV g i (flip P l) cs e -- ((table i values) ! e).l - - _ -> returnC $ P t' l - - S t v -> do -- t ! v - t' <- compTable g t - v' <- comp g v - t1 <- case t' of ----- V (RecType fs) _ -> uncurrySelect g fs t' v' ----- T (TComp (RecType fs)) _ -> uncurrySelect g fs t' v' - _ -> return $ S t' v' - compSelect g t1 - - -- normalize away empty tokens - K "" -> return Empty -- [] - - -- glue if you can - Glue x0 y0 -> do -- x0 + y0 - x <- comp g x0 - y <- comp g y0 - case (x,y) of - (Error{},_) -> return x - (_,Error{}) -> return y - (FV ks,_) -> do -- (k|k') + y - kys <- mapM (comp g . flip Glue y) ks - return $ variants kys - (_,FV ks) -> do -- x + (k|k') - xks <- mapM (comp g . Glue x) ks - return $ variants xks - - (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e -- (table cs ! e) + s - (s, S (T i cs) e) -> prawitz g i (Glue s) cs e -- s + (table cs ! e) - (S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e -- same with values - (s, S (V i cs) e) -> prawitzV g i (Glue s) cs e - (_,Empty) -> return x -- x + [] - (Empty,_) -> return y - (K a, K b) -> return $ K (a ++ b) -- "foo" + "bar" - (_, Alts d vs) -> do -- x + pre {...} ----- (K a, Alts (d,vs)) -> do - let glx = Glue x - comp g $ Alts (glx d) [(glx v,c) | (v,c) <- vs] - (Alts _ _, ka) -> errr $ checks [do -- pre {...} + ka - y' <- strsFromTerm ka ----- (Alts _, K a) -> checks [do - x' <- strsFromTerm x -- this may fail when compiling opers - return $ variants [ - foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y'] ----- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x'] - ,return $ Glue x y - ] - (C u v,_) -> comp g $ C u (Glue v y) -- (u ++ v) + y - (_,C u v) -> comp g $ C (Glue x u) v -- x ++ (u ++ v) - - _ -> do - mapM_ checkNoArgVars [x,y] - r <- composOp (comp g) t - returnC r - - Alts d aa -> do -- pre {...} - d' <- comp g d - aa' <- mapM (compInAlts g) aa - returnC (Alts d' aa') - - -- remove empty - C a b -> do -- a ++ b - a0 <- comp g a - b0 <- comp g b - let (a',b') = strForm (C a0 b0) - case (a',b') of - (Error{},_) -> return a' - (_,Error{}) -> return b' - - (Alts _ _, K d) -> errr $ checks [do -- pre {...} ++ "d" - as <- strsFromTerm a' -- this may fail when compiling opers - return $ variants [ - foldr1 C (map K (str2strings (plusStr v (str d)))) | v <- as] - , - return $ C a' b' - ] - (Alts _ _, C (K d) e) -> errr $ checks [do -- pre {...} ++ ("d" ++ e) - as <- strsFromTerm a' -- this may fail when compiling opers - return $ C (variants [ - foldr1 C (map K (str2strings (plusStr v (str d)))) | v <- as]) e - , - return $ C a' b' - ] - - (Empty,_) -> returnC b' -- [] ++ b' - (_,Empty) -> returnC a' -- a' ++ [] - _ -> returnC $ C a' b' - - -- reduce free variation as much as you can - FV ts -> mapM (comp g) ts >>= returnC . variants -- variants {...} - - -- merge record extensions if you can - ExtR r s -> do -- r ** s - r' <- comp g r - s' <- comp g s - case (r',s') of - (Error{},_) -> return r' - (_,Error{}) -> return s' - (R rs, R ss) -> errr $ plusRecord r' s' - (RecType rs, RecType ss) -> errr $ plusRecType r' s' - _ -> return $ ExtR r' s' - - ELin c r -> do -- lin c r - r' <- comp g r - unlockRecord c r' - - T _ _ -> compTable g t -- table { ... p => t ... } - V _ _ -> compTable g t -- table [ ... v ... ] - - -- otherwise go ahead - _ -> composOp (comp g) t >>= returnC - - where - --{...}.l - project l = maybe (fail_project l) (comp g) . try_project l - try_project l = fmap snd . lookup l - fail_project l = fail (render (text "no value for label" <+> ppLabel l)) - - compApp g (App f a) = do -- (f a) - f' <- hnf g f - a' <- comp g a - case (f',a') of - (Error{},_) -> return f' - (Abs _ x b, FV as) -> -- (\x -> b) (variants {...}) - liftM variants $ mapM (\c -> comp (ext x c g) b) as - (_, FV as) -> liftM variants $ mapM (\c -> comp g (App f' c)) as - (FV fs, _) -> liftM variants $ mapM (\c -> comp g (App c a')) fs - (Abs _ x b,_) -> comp (ext x a' g) b -- (\x -> b) a -- normal beta conv. - - (QC _,_) -> returnC $ App f' a' -- (C a') -- constructor application - - (S (T i cs) e,_) -> prawitz g i (flip App a') cs e -- (table cs ! e) a' - (S (V i cs) e,_) -> prawitzV g i (flip App a') cs e - - _ -> case appPredefined (App f' a') of - Ok (t',b) -> if b then return t' else comp g t' - Bad s -> runtime_error s - - hnf, comp :: Substitution -> Term -> Comp Term - hnf = comput False - comp = comput True - - look c = errr (lookupResDef gr c) - {- -- This seems to loop in the greek example: - look c = --trace ("look "++show c) $ - optcomp =<< errr (lookupResDef gr c) - where - optcomp t = if t==Q c - then --trace "looking up undefined oper" $ - return t - else comp [] t -- g or []? - -} - - ext x a g = (x,a):g -- extend environment with new variable and its value - - returnC = return --- . computed - - variants ts = case nub ts of - [t] -> t - ts -> FV ts - - isCan v = case v of -- is canonical (and should be matched by a pattern) - Con _ -> True - QC _ -> True - App f a -> isCan f && isCan a - R rs -> all (isCan . snd . snd) rs - _ -> False - - compPatternMacro p = case p of - PM c -> case look c of - Identity (EPatt p') -> compPatternMacro p' - -- _ -> fail (render (text "pattern expected as value of" $$ nest 2 (ppPatt Unqualified 0 p))) - PAs x p -> do - p' <- compPatternMacro p - return $ PAs x p' - PAlt p q -> do - p' <- compPatternMacro p - q' <- compPatternMacro q - return $ PAlt p' q' - PSeq p q -> do - p' <- compPatternMacro p - q' <- compPatternMacro q - return $ PSeq p' q' - PRep p -> do - p' <- compPatternMacro p - return $ PRep p' - PNeg p -> do - p' <- compPatternMacro p - return $ PNeg p' - PR rs -> do - rs' <- mapPairsM compPatternMacro rs - return $ PR rs' - - _ -> return p - - compSelect g (S t' v') = case v' of -- t' ! v' - FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants - ----- S (T i cs) e -> prawitz g i (S t') cs e -- AR 8/7/2010 sometimes better ----- S (V i cs) e -> prawitzV g i (S t') cs e -- sometimes much worse - - - _ -> case t' of - Error{} -> return t' - FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants - - T _ [(PW,c)] -> comp g c -- (\\_ => c) ! v' - T _ [(PT _ PW,c)] -> comp g c -- (\\(_ : typ) => c) ! v' - - T _ [(PV z,c)] -> comp (ext z v' g) c -- (\\z => c) ! v' - 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 -- (table [...ts...]) ! v' - vs <- no_error $ 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 -- (table {...cc...}) ! v' - case matchPattern cc v' of - Ok (c,g') -> comp (g' ++ g) c - _ | isCan v' -> fail (render (text "missing case" <+> ppTerm Unqualified 0 v' <+> text "in" <+> ppTerm Unqualified 0 t)) - _ -> return $ S t' v' -- if v' is not canonical - - S (T i cs) e -> prawitz g i (flip S v') cs e -- (table {...cs...} ! e) ! v' - S (V i cs) e -> prawitzV g i (flip S v') cs e - _ -> returnC $ S t' v' - - --- needed to match records with and without type information - ---- todo: eliminate linear search in a list of records! - lookupR v vs = case v of - R rs -> lookup ([(x,y) | (x,(_,y)) <- rs]) - [([(x,y) | (x,(_,y)) <- rs],v) | (R rs,v) <- vs] - _ -> lookup v vs - - -- case-expand tables: branches for every value of argument type - -- if already expanded, don't expand again - compTable g t = case t of - T i@(TComp ty) cs -> do - -- if there are no variables, don't even go inside - cs' <- if (null g) then return cs else mapPairsM (comp g) cs ----- return $ V ty (map snd cs') - return $ T i cs' - V ty cs -> do - ty' <- comp g ty - -- if there are no variables, don't even go inside - cs' <- if (null g) then return cs else mapM (comp g) cs - return $ V ty' cs' - - T i cs -> do - pty0 <- errr $ getTableType i - ptyp <- comp g pty0 - case allParamValues gr ptyp of - Ok vs0 -> do - let vs = vs0 ---- [Val v ptyp i | (v,i) <- zip vs0 [0..]] - ps0 <- mapM (compPatternMacro . fst) cs - cs' <- mapM (compBranchOpt g) (zip ps0 (map snd cs)) - sts <- no_error $ mapM (matchPattern cs') vs - ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts - ps <- no_error $ mapM term2patt vs - let ps' = ps --- PT ptyp (head ps) : tail ps ----- return $ V ptyp ts -- to save space, just course of values - return $ T (TComp ptyp) (zip ps' ts) - _ -> do - ps0 <- mapM (compPatternMacro . fst) cs - - cs' <- mapM (compBranch g) (zip ps0 (map snd cs)) ------ cs' <- return (zip ps0 (map snd cs)) --- probably right AR 22/8/2011 but can leave uninstantiated variables :-( - ----- cs' <- mapM (compBranch g) cs - return $ T i cs' -- happens with variable types - _ -> comp g t - - compBranch g (p,v) = do -- compute a branch in a table - let g' = contP p ++ g -- add the pattern's variables to environment - v' <- comp g' v - return (p,v') - - compBranchOpt g c@(p,v) = case contP p of - [] -> return c - _ -> {-err (const (return c)) return $-} compBranch g c - - -- collect the context of variables of a pattern - contP p = case p of - PV x -> [(x,Vr x)] - PC _ ps -> concatMap contP ps - PP _ ps -> concatMap contP ps - PT _ p -> contP p - PR rs -> concatMap (contP . snd) rs - - PAs x p -> (x,Vr x) : contP p - - PSeq p q -> concatMap contP [p,q] - PAlt p q -> concatMap contP [p,q] - PRep p -> contP p - PNeg p -> contP p - - _ -> [] - - prawitz g i f cs e = do - cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs] - return $ S (T i cs') e - prawitzV g i f cs e = do - cs' <- mapM (comp g) [(f v) | v <- cs] - return $ S (V i cs') e - - compInAlts g (v,c) = do - v' <- comp g v - c' <- comp g c - c2 <- case c' of - EPatt p -> liftM Strs $ getPatts p - _ -> return c' - return (v',c2) - where - getPatts p = case p of - PAlt a b -> liftM2 (++) (getPatts a) (getPatts b) - PString s -> return [K s] - PSeq a b -> do - as <- getPatts a - bs <- getPatts b - return [K (s ++ t) | K s <- as, K t <- bs] - _ -> fail (render (text "not valid pattern in pre expression" <+> ppPatt Unqualified 0 p)) - - strForm s = case s of - C (C a b) c -> let (a1,a2) = strForm a in (a1, ccStr a2 (ccStr b c)) - C a b -> (a,b) - _ -> (s,Empty) - - ccStr a b = case (a,b) of - (Empty,_) -> b - (_,Empty) -> a - _ -> C a b - -{- ---- - uncurrySelect g fs t v = do - ts <- mapM (allParamValues gr . snd) fs - vs <- mapM (comp g) [P v r | r <- map fst fs] - return $ reorderSelect t fs ts vs - - reorderSelect t fs pss vs = case (t,fs,pss,vs) of - (V _ ts, f:fs1, ps:pss1, v:vs1) -> - S (V (snd f) - [reorderSelect (V (RecType fs1) t) fs1 pss1 vs1 | - t <- segments (length ts `div` length ps) ts]) v - (T (TComp _) cs, f:fs1, ps:pss1, v:vs1) -> - S (T (TComp (snd f)) - [(p,reorderSelect (T (TComp (RecType fs1)) c) fs1 pss1 vs1) | - (ep,c) <- zip ps (segments (length cs `div` length ps) cs), - let Ok p = term2patt ep]) v - _ -> t - - segments i xs = - let (x0,xs1) = splitAt i xs in x0 : takeWhile (not . null) (segments i xs1) --} - - --- | argument variables cannot be glued -checkNoArgVars :: Term -> Comp Term -checkNoArgVars t = case t of - Vr x | isArgIdent x -> fail $ glueErrorMsg $ ppTerm Unqualified 0 t - _ -> composOp checkNoArgVars t - -glueErrorMsg s = - render (text "Cannot glue (+) term with run-time variable" <+> s <> char '.' $$ - text "Use Prelude.bind instead.") - -getArgType t = case t of - V ty _ -> return ty - T (TComp ty) _ -> return ty - _ -> fail (render (text "cannot get argument type of table" $$ nest 2 (ppTerm Unqualified 0 t))) - -{- --- Old -checkPredefError sgr t = case t of - App (Q (mod,f)) s | mod == cPredef && f == cError -> fail $ showTerm sgr TermPrintOne Unqualified s - _ -> composOp (checkPredefError sgr) t - -predef_error s = App (Q (cPredef,cError)) (K s) --} --} diff --git a/src/compiler/GF/Compile/Compute/ConcreteStrict.hs b/src/compiler/GF/Compile/Compute/ConcreteStrict.hs deleted file mode 100644 index df343adec..000000000 --- a/src/compiler/GF/Compile/Compute/ConcreteStrict.hs +++ /dev/null @@ -1,494 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Compile.Concrete.Compute --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/01 15:39:12 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.19 $ --- --- Computation of source terms. Used in compilation and in @cc@ command. ------------------------------------------------------------------------------ - -module GF.Compile.Compute.ConcreteStrict (computeConcrete, computeTerm,computeConcreteRec,checkPredefError) where - -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Option ---import GF.Infra.Modules -import GF.Data.Str -import GF.Grammar.ShowTerm -import GF.Grammar.Printer -import GF.Grammar.Predef -import GF.Grammar.Macros -import GF.Grammar.Lookup ---import GF.Compile.Refresh -import GF.Grammar.PatternMatch -import GF.Grammar.Lockfield (isLockLabel,unlockRecord) ---- - -import GF.Compile.Compute.AppPredefined - -import Data.List (nub,intersperse) -import Control.Monad (liftM2, liftM) -import GF.Text.Pretty - -----import Debug.Trace - --- | computation of concrete syntax terms into normal form --- used mainly for partial evaluation -computeConcrete :: SourceGrammar -> Term -> Err Term -computeConcrete g t = {- refreshTerm t >>= -} computeTerm g [] t -computeConcreteRec g t = {- refreshTerm t >>= -} computeTermOpt True g [] t - --- False means: no evaluation under Abs -computeTerm :: SourceGrammar -> Substitution -> Term -> Err Term -computeTerm = computeTermOpt False - --- rec=True is used if it cannot be assumed that looked-up constants --- have already been computed (mainly with -optimize=noexpand in .gfr) - -computeTermOpt :: Bool -> SourceGrammar -> Substitution -> Term -> Err Term -computeTermOpt rec gr = comput True where - - -- full = True means full evaluation under Abs - comput full g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging - case t of - - Q (p,c) | p == cPredef -> return t -- qualified constant - | otherwise -> look (p,c) - - Vr x -> do -- local variable - t' <- maybe (Bad (render (text "no value given to variable" <+> ppIdent x))) - return $ lookup x g - case t' of - _ | t == t' -> return t - _ -> comp g t' --- why compute again? AR 25/8/2011 - - -- Abs x@(IA _) b -> do - Abs _ _ _ | full -> do -- \xs -> b - let (xs,b1) = termFormCnc t - b' <- comp ([(x,Vr x) | (_,x) <- xs] ++ g) b1 - return $ mkAbs xs b' - -- b' <- comp (ext x (Vr x) g) b - -- return $ Abs x b' - Abs _ _ _ -> return t -- hnf - - Let (x,(ty,a)) b -> do -- let x : ty = a in b - a' <- comp g a - comp (ext x a' g) b - -{- -- trying to prevent Let expansion with non-evaluated exps. AR 19/8/2011 - Let (x,(ty,a)) b -> do - a' <- comp g a - let ea' = checkNoArgVars a' - case ea' of - Ok v -> comp (ext x v g) b - _ -> return $ Let (x,(ty,a')) b --} - - Prod b x a t -> do -- (x : a) -> t ; b for hiding - a' <- comp g a - t' <- comp (ext x (Vr x) g) t - return $ Prod b x a' t' - - -- beta-convert: simultaneous for as many arguments as possible - App f a -> case appForm t of -- (f a) --> (h as) - (h,as) | length as > 1 -> do - h' <- hnf g h - as' <- mapM (comp g) as - case h' of - _ | not (null [() | FV _ <- as']) -> compApp g (mkApp h' as') - c@(QC _) -> do - return $ mkApp c as' - Q (mod,f) | mod == cPredef -> do - (t',b) <- appPredefined (mkApp h' as') - if b then return t' else comp g t' - - Abs _ _ _ -> do - let (xs,b) = termFormCnc h' - let g' = (zip (map snd xs) as') ++ g - let as2 = drop (length xs) as' - let xs2 = drop (length as') xs - b' <- comp g' (mkAbs xs2 b) - if null as2 then return b' else comp g (mkApp b' as2) - - _ -> compApp g (mkApp h' as') - _ -> compApp g t - - P t l | isLockLabel l -> return $ R [] -- t.lock_C - ---- a workaround 18/2/2005: take this away and find the reason - ---- why earlier compilation destroys the lock field - - - P t l -> do -- t.l - t' <- comp g t - case t' of - FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants -- (r| r').l - R r -> maybe (Bad (render (text "no value for label" <+> ppLabel l))) --{...}.l - (comp g . snd) $ - lookup l $ reverse r - - ExtR a (R b) -> -- (a ** {...}).l - case comp g (P (R b) l) of - Ok v -> return v - _ -> comp g (P a l) - ---- { - --- this is incorrect, since b can contain the proper value - ExtR (R a) b -> -- NOT POSSIBLE both a and b records! - case comp g (P (R a) l) of - Ok v -> return v - _ -> comp g (P b l) ---- - } --- - - S (T i cs) e -> prawitz g i (flip P l) cs e -- ((table i branches) ! e).l - S (V i cs) e -> prawitzV g i (flip P l) cs e -- ((table i values) ! e).l - - _ -> returnC $ P t' l - - S t v -> do -- t ! v - t' <- compTable g t - v' <- comp g v - t1 <- case t' of ----- V (RecType fs) _ -> uncurrySelect g fs t' v' ----- T (TComp (RecType fs)) _ -> uncurrySelect g fs t' v' - _ -> return $ S t' v' - compSelect g t1 - - -- normalize away empty tokens - K "" -> return Empty -- [] - - -- glue if you can - Glue x0 y0 -> do -- x0 + y0 - x <- comp g x0 - y <- comp g y0 - case (x,y) of - (FV ks,_) -> do -- (k|k') + y - kys <- mapM (comp g . flip Glue y) ks - return $ variants kys - (_,FV ks) -> do -- x + (k|k') - xks <- mapM (comp g . Glue x) ks - return $ variants xks - - (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e -- (table cs ! e) + s - (s, S (T i cs) e) -> prawitz g i (Glue s) cs e -- s + (table cs ! e) - (S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e -- same with values - (s, S (V i cs) e) -> prawitzV g i (Glue s) cs e - (_,Empty) -> return x -- x + [] - (Empty,_) -> return y - (K a, K b) -> return $ K (a ++ b) -- "foo" + "bar" - (_, Alts d vs) -> do -- x + pre {...} ----- (K a, Alts (d,vs)) -> do - let glx = Glue x - comp g $ Alts (glx d) [(glx v,c) | (v,c) <- vs] - (Alts _ _, ka) -> checks [do -- pre {...} + ka - y' <- strsFromTerm ka ----- (Alts _, K a) -> checks [do - x' <- strsFromTerm x -- this may fail when compiling opers - return $ variants [ - foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y'] ----- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x'] - ,return $ Glue x y - ] - (C u v,_) -> comp g $ C u (Glue v y) -- (u ++ v) + y - - _ -> do - mapM_ checkNoArgVars [x,y] - r <- composOp (comp g) t - returnC r - - Alts d aa -> do -- pre {...} - d' <- comp g d - aa' <- mapM (compInAlts g) aa - returnC (Alts d' aa') - - -- remove empty - C a b -> do -- a ++ b - a' <- comp g a - b' <- comp g b - case (a',b') of - (Alts _ _, K d) -> checks [do -- pre {...} ++ "d" - as <- strsFromTerm a' -- this may fail when compiling opers - return $ variants [ - foldr1 C (map K (str2strings (plusStr v (str d)))) | v <- as] - , - return $ C a' b' - ] - (Alts _ _, C (K d) e) -> checks [do -- pre {...} ++ ("d" ++ e) - as <- strsFromTerm a' -- this may fail when compiling opers - return $ C (variants [ - foldr1 C (map K (str2strings (plusStr v (str d)))) | v <- as]) e - , - return $ C a' b' - ] - (Empty,_) -> returnC b' -- [] ++ b' - (_,Empty) -> returnC a' -- a' ++ [] - _ -> returnC $ C a' b' - - -- reduce free variation as much as you can - FV ts -> mapM (comp g) ts >>= returnC . variants -- variants {...} - - -- merge record extensions if you can - ExtR r s -> do -- r ** s - r' <- comp g r - s' <- comp g s - case (r',s') of - (R rs, R ss) -> plusRecord r' s' - (RecType rs, RecType ss) -> plusRecType r' s' - _ -> return $ ExtR r' s' - - ELin c r -> do -- lin c r - r' <- comp g r - unlockRecord c r' - - T _ _ -> compTable g t -- table { ... p => t ... } - V _ _ -> compTable g t -- table [ ... v ... ] - - -- otherwise go ahead - _ -> composOp (comp g) t >>= returnC - - where - - compApp g (App f a) = do -- (f a) - f' <- hnf g f - a' <- comp g a - case (f',a') of - (Abs _ x b, FV as) -> -- (\x -> b) (variants {...}) - mapM (\c -> comp (ext x c g) b) as >>= return . variants - (_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants - (FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants - (Abs _ x b,_) -> comp (ext x a' g) b -- (\x -> b) a -- normal beta conv. - - (QC _,_) -> returnC $ App f' a' -- (C a') -- constructor application - - (S (T i cs) e,_) -> prawitz g i (flip App a') cs e -- (table cs ! e) a' - (S (V i cs) e,_) -> prawitzV g i (flip App a') cs e - - _ -> do - (t',b) <- appPredefined (App f' a') - if b then return t' else comp g t' - - hnf = comput False - comp = comput True - - look c - | rec = lookupResDef gr c >>= comp [] - | otherwise = lookupResDef gr c - - ext x a g = (x,a):g -- extend environment with new variable and its value - - returnC = return --- . computed - - variants ts = case nub ts of - [t] -> t - ts -> FV ts - - isCan v = case v of -- is canonical (and should be matched by a pattern) - Con _ -> True - QC _ -> True - App f a -> isCan f && isCan a - R rs -> all (isCan . snd . snd) rs - _ -> False - - compPatternMacro p = case p of - PM c -> case look c of - Ok (EPatt p') -> compPatternMacro p' - _ -> Bad (render (text "pattern expected as value of" $$ nest 2 (ppPatt Unqualified 0 p))) - PAs x p -> do - p' <- compPatternMacro p - return $ PAs x p' - PAlt p q -> do - p' <- compPatternMacro p - q' <- compPatternMacro q - return $ PAlt p' q' - PSeq p q -> do - p' <- compPatternMacro p - q' <- compPatternMacro q - return $ PSeq p' q' - PRep p -> do - p' <- compPatternMacro p - return $ PRep p' - PNeg p -> do - p' <- compPatternMacro p - return $ PNeg p' - PR rs -> do - rs' <- mapPairsM compPatternMacro rs - return $ PR rs' - - _ -> return p - - compSelect g (S t' v') = case v' of -- t' ! v' - FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants - ----- S (T i cs) e -> prawitz g i (S t') cs e -- AR 8/7/2010 sometimes better ----- S (V i cs) e -> prawitzV g i (S t') cs e -- sometimes much worse - - - _ -> case t' of - FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants - - T _ [(PW,c)] -> comp g c -- (\\_ => c) ! v' - T _ [(PT _ PW,c)] -> comp g c -- (\\(_ : typ) => c) ! v' - - T _ [(PV z,c)] -> comp (ext z v' g) c -- (\\z => c) ! v' - 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 -- (table [...ts...]) ! v' - 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 -- (table {...cc...}) ! v' - case matchPattern cc v' of - Ok (c,g') -> comp (g' ++ g) c - _ | isCan v' -> Bad (render (text "missing case" <+> ppTerm Unqualified 0 v' <+> text "in" <+> ppTerm Unqualified 0 t)) - _ -> return $ S t' v' -- if v' is not canonical - - S (T i cs) e -> prawitz g i (flip S v') cs e -- (table {...cs...} ! e) ! v' - S (V i cs) e -> prawitzV g i (flip S v') cs e - _ -> returnC $ S t' v' - - --- needed to match records with and without type information - ---- todo: eliminate linear search in a list of records! - lookupR v vs = case v of - R rs -> lookup ([(x,y) | (x,(_,y)) <- rs]) - [([(x,y) | (x,(_,y)) <- rs],v) | (R rs,v) <- vs] - _ -> lookup v vs - - -- case-expand tables: branches for every value of argument type - -- if already expanded, don't expand again - compTable g t = case t of - T i@(TComp ty) cs -> do - -- if there are no variables, don't even go inside - cs' <- if (null g) then return cs else mapPairsM (comp g) cs ----- return $ V ty (map snd cs') - return $ T i cs' - V ty cs -> do - ty' <- comp g ty - -- if there are no variables, don't even go inside - cs' <- if (null g) then return cs else mapM (comp g) cs - return $ V ty' cs' - - T i cs -> do - pty0 <- getTableType i - ptyp <- comp g pty0 - case allParamValues gr ptyp of - Ok vs0 -> do - let vs = vs0 ---- [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 - ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts - ps <- mapM term2patt vs - let ps' = ps --- PT ptyp (head ps) : tail ps ----- return $ V ptyp ts -- to save space, just course of values - return $ T (TComp ptyp) (zip ps' ts) - _ -> do - ps0 <- mapM (compPatternMacro . fst) cs - - cs' <- mapM (compBranch g) (zip ps0 (map snd cs)) ------ cs' <- return (zip ps0 (map snd cs)) --- probably right AR 22/8/2011 but can leave uninstantiated variables :-( - ----- cs' <- mapM (compBranch g) cs - return $ T i cs' -- happens with variable types - _ -> comp g t - - compBranch g (p,v) = do -- compute a branch in a table - let g' = contP p ++ g -- add the pattern's variables to environment - v' <- comp g' v - return (p,v') - - compBranchOpt g c@(p,v) = case contP p of - [] -> return c - _ -> err (const (return c)) return $ compBranch g c - - -- collect the context of variables of a pattern - contP p = case p of - PV x -> [(x,Vr x)] - PC _ ps -> concatMap contP ps - PP _ ps -> concatMap contP ps - PT _ p -> contP p - PR rs -> concatMap (contP . snd) rs - - PAs x p -> (x,Vr x) : contP p - - PSeq p q -> concatMap contP [p,q] - PAlt p q -> concatMap contP [p,q] - PRep p -> contP p - PNeg p -> contP p - - _ -> [] - - prawitz g i f cs e = do - cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs] - return $ S (T i cs') e - prawitzV g i f cs e = do - cs' <- mapM (comp g) [(f v) | v <- cs] - return $ S (V i cs') e - - compInAlts g (v,c) = do - v' <- comp g v - c' <- comp g c - c2 <- case c' of - EPatt p -> liftM Strs $ getPatts p - _ -> return c' - return (v',c2) - where - getPatts p = case p of - PAlt a b -> liftM2 (++) (getPatts a) (getPatts b) - PString s -> return [K s] - PSeq a b -> do - as <- getPatts a - bs <- getPatts b - return [K (s ++ t) | K s <- as, K t <- bs] - _ -> fail (render (text "not valid pattern in pre expression" <+> ppPatt Unqualified 0 p)) - -{- ---- - uncurrySelect g fs t v = do - ts <- mapM (allParamValues gr . snd) fs - vs <- mapM (comp g) [P v r | r <- map fst fs] - return $ reorderSelect t fs ts vs - - reorderSelect t fs pss vs = case (t,fs,pss,vs) of - (V _ ts, f:fs1, ps:pss1, v:vs1) -> - S (V (snd f) - [reorderSelect (V (RecType fs1) t) fs1 pss1 vs1 | - t <- segments (length ts `div` length ps) ts]) v - (T (TComp _) cs, f:fs1, ps:pss1, v:vs1) -> - S (T (TComp (snd f)) - [(p,reorderSelect (T (TComp (RecType fs1)) c) fs1 pss1 vs1) | - (ep,c) <- zip ps (segments (length cs `div` length ps) cs), - let Ok p = term2patt ep]) v - _ -> t - - segments i xs = - let (x0,xs1) = splitAt i xs in x0 : takeWhile (not . null) (segments i xs1) --} - - --- | argument variables cannot be glued -checkNoArgVars :: Term -> Err Term -checkNoArgVars t = case t of - Vr (IA _ _) -> Bad $ glueErrorMsg $ ppTerm Unqualified 0 t - Vr (IAV _ _ _) -> Bad $ glueErrorMsg $ ppTerm Unqualified 0 t - _ -> composOp checkNoArgVars t - -glueErrorMsg s = - render (text "Cannot glue (+) term with run-time variable" <+> s <> char '.' $$ - text "Use Prelude.bind instead.") - -getArgType t = case t of - V ty _ -> return ty - T (TComp ty) _ -> return ty - _ -> Bad (render (text "cannot get argument type of table" $$ nest 2 (ppTerm Unqualified 0 t))) - - -checkPredefError :: SourceGrammar -> Term -> Err Term -checkPredefError sgr t = case t of - App (Q (mod,f)) s | mod == cPredef && f == cError -> Bad $ showTerm sgr TermPrintOne Unqualified s - _ -> composOp (checkPredefError sgr) t - diff --git a/src/compiler/GF/Compile/Refresh.hs b/src/compiler/GF/Compile/Refresh.hs deleted file mode 100644 index 999d8b083..000000000 --- a/src/compiler/GF/Compile/Refresh.hs +++ /dev/null @@ -1,153 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Refresh --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:27 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Compile.Refresh ({-refreshTermN, refreshTerm, - refreshModule-} - ) where -{- -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Grammar.Macros -import Control.Monad - -refreshTerm :: Term -> Err Term -refreshTerm = refreshTermN 0 - -refreshTermN :: Int -> Term -> Err Term -refreshTermN i e = liftM snd $ refreshTermKN i e - -refreshTermKN :: Int -> Term -> Err (Int,Term) -refreshTermKN i e = liftM (\ (t,(_,i)) -> (i,t)) $ - appSTM (refresh e) (initIdStateN i) - -refresh :: Term -> STM IdState Term -refresh e = case e of - - Vr x -> liftM Vr (lookVar x) - Abs b x t -> liftM2 (Abs b) (refVarPlus x) (refresh t) - - Prod b x a t -> do - a' <- refresh a - x' <- refVar x - t' <- refresh t - return $ Prod b x' a' t' - - Let (x,(mt,a)) b -> do - a' <- refresh a - mt' <- case mt of - Just t -> refresh t >>= (return . Just) - _ -> return mt - x' <- refVar x - b' <- refresh b - return (Let (x',(mt',a')) b') - - R r -> liftM R $ refreshRecord r - - ExtR r s -> liftM2 ExtR (refresh r) (refresh s) - - T i cc -> liftM2 T (refreshTInfo i) (mapM refreshCase cc) - - App f a -> liftM2 App (inBlockSTM (refresh f)) (refresh a) - - _ -> composOp refresh e - -refreshCase :: (Patt,Term) -> STM IdState (Patt,Term) -refreshCase (p,t) = liftM2 (,) (refreshPatt p) (refresh t) - -refreshPatt p = case p of - PV x -> liftM PV (refVar x) - PC c ps -> liftM (PC c) (mapM refreshPatt ps) - PP c ps -> liftM (PP c) (mapM refreshPatt ps) - PR r -> liftM PR (mapPairsM refreshPatt r) - PT t p' -> liftM2 PT (refresh t) (refreshPatt p') - - PAs x p' -> liftM2 PAs (refVar x) (refreshPatt p') - - PSeq p' q' -> liftM2 PSeq (refreshPatt p') (refreshPatt q') - PAlt p' q' -> liftM2 PAlt (refreshPatt p') (refreshPatt q') - PRep p' -> liftM PRep (refreshPatt p') - PNeg p' -> liftM PNeg (refreshPatt p') - - _ -> return p - -refreshRecord r = case r of - [] -> return r - (x,(mt,a)):b -> do - a' <- refresh a - mt' <- case mt of - Just t -> refresh t >>= (return . Just) - _ -> return mt - b' <- refreshRecord b - return $ (x,(mt',a')) : b' - -refreshTInfo i = case i of - TTyped t -> liftM TTyped $ refresh t - TComp t -> liftM TComp $ refresh t - TWild t -> liftM TWild $ refresh t - _ -> return i - --- for abstract syntax - -refreshEquation :: Equation -> Err ([Patt],Term) -refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) where - refr (ps,t) = liftM2 (,) (mapM refreshPatt ps) (refresh t) - --- for concrete and resource in grammar, before optimizing - ---refreshGrammar :: SourceGrammar -> Err SourceGrammar ---refreshGrammar = liftM (mGrammar . snd) . foldM refreshModule (0,[]) . modules - -refreshModule :: (Int,SourceGrammar) -> SourceModule -> Err (Int,[SourceModule]) -refreshModule (k,sgr) mi@(i,mo) - | isModCnc mo || isModRes mo = do - (k',js') <- foldM refreshRes (k,[]) $ tree2list $ jments mo - return (k', (i,mo{jments=buildTree js'}) : modules sgr) - | otherwise = return (k, mi:modules sgr) - where - refreshRes (k,cs) ci@(c,info) = case info of - ResOper ptyp (Just (L loc trm)) -> do ---- refresh ptyp - (k',trm') <- refreshTermKN k trm - return $ (k', (c, ResOper ptyp (Just (L loc trm'))):cs) - ResOverload os tyts -> do - (k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $ - appSTM (mapPairsM (\(L loc t) -> liftM (L loc) (refresh t)) tyts) (initIdStateN k) - return $ (k', (c, ResOverload os tyts'):cs) - CncCat mt md mr mn mpmcfg-> do - (k,md) <- case md of - Just (L loc trm) -> do (k,trm) <- refreshTermKN k trm - return (k,Just (L loc trm)) - Nothing -> return (k,Nothing) - (k,mr) <- case mr of - Just (L loc trm) -> do (k,trm) <- refreshTermKN k trm - return (k,Just (L loc trm)) - Nothing -> return (k,Nothing) - return (k, (c, CncCat mt md mr mn mpmcfg):cs) - CncFun mt (Just (L loc trm)) mn mpmcfg -> do ---- refresh pn - (k',trm') <- refreshTermKN k trm - return $ (k', (c, CncFun mt (Just (L loc trm')) mn mpmcfg):cs) - _ -> return (k, ci:cs) - - --- running monad and returning to initial state - -inBlockSTM :: STM s a -> STM s a -inBlockSTM mo = do - s <- readSTM - v <- mo - writeSTM s - return v - - --}
\ No newline at end of file diff --git a/src/compiler/GF/Compile/SubExOpt.hs b/src/compiler/GF/Compile/SubExOpt.hs index 4c056f479..56e41d55c 100644 --- a/src/compiler/GF/Compile/SubExOpt.hs +++ b/src/compiler/GF/Compile/SubExOpt.hs @@ -24,29 +24,29 @@ module GF.Compile.SubExOpt (subexpModule,unsubexpModule) where import GF.Grammar.Grammar -import GF.Grammar.Lookup +import GF.Grammar.Lookup(lookupResDef) import GF.Infra.Ident import qualified GF.Grammar.Macros as C -import GF.Data.Operations +import GF.Data.ErrM(fromErr) -import Control.Monad +import Control.Monad.State.Strict(State,evalState,get,put) import Data.Map (Map) import qualified Data.Map as Map -subexpModule :: SourceModule -> SourceModule -subexpModule (n,mo) = errVal (n,mo) $ do - let ljs = tree2list (jments mo) - (tree,_) <- appSTM (getSubtermsMod n ljs) (Map.empty,0) - js2 <- liftM buildTree $ addSubexpConsts n tree $ ljs - return (n,mo{jments=js2}) +--subexpModule :: SourceModule -> SourceModule +subexpModule (n,mo) = + let ljs = Map.toList (jments mo) + tree = evalState (getSubtermsMod n ljs) (Map.empty,0) + js2 = Map.fromList $ addSubexpConsts n tree $ ljs + in (n,mo{jments=js2}) -unsubexpModule :: SourceModule -> SourceModule +--unsubexpModule :: SourceModule -> SourceModule unsubexpModule sm@(i,mo) | hasSub ljs = (i,mo{jments=rebuild (map unparInfo ljs)}) | otherwise = sm where - ljs = tree2list (jments mo) + ljs = Map.toList (jments mo) -- perform this iff the module has opers hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs] @@ -57,33 +57,33 @@ unsubexpModule sm@(i,mo) _ -> [(c,info)] unparTerm t = case t of Q (m,c) | isOperIdent c -> --- name convention of subexp opers - errVal t $ liftM unparTerm $ lookupResDef gr (m,c) + fromErr t $ fmap unparTerm $ lookupResDef gr (m,c) _ -> C.composSafeOp unparTerm t gr = mGrammar [sm] - rebuild = buildTree . concat + rebuild = Map.fromList . concat -- implementation type TermList = Map Term (Int,Int) -- number of occs, id -type TermM a = STM (TermList,Int) a +type TermM a = State (TermList,Int) a addSubexpConsts :: - Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> Err [(Ident,Info)] + Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> [(Ident,Info)] addSubexpConsts mo tree lins = do let opers = [oper id trm | (trm,(_,id)) <- list] - mapM mkOne $ opers ++ lins + map mkOne $ opers ++ lins where mkOne (f,def) = case def of - CncFun xs (Just (L loc trm)) pn pf -> do - trm' <- recomp f trm - return (f,CncFun xs (Just (L loc trm')) pn pf) - ResOper ty (Just (L loc trm)) -> do - trm' <- recomp f trm - return (f,ResOper ty (Just (L loc trm'))) - _ -> return (f,def) + CncFun xs (Just (L loc trm)) pn pf -> + let trm' = recomp f trm + in (f,CncFun xs (Just (L loc trm')) pn pf) + ResOper ty (Just (L loc trm)) -> + let trm' = recomp f trm + in (f,ResOper ty (Just (L loc trm'))) + _ -> (f,def) recomp f t = case Map.lookup t tree of - Just (_,id) | operIdent id /= f -> return $ Q (mo, operIdent id) - _ -> C.composOp (recomp f) t + Just (_,id) | operIdent id /= f -> Q (mo, operIdent id) + _ -> C.composSafeOp (recomp f) t list = Map.toList tree @@ -93,7 +93,7 @@ addSubexpConsts mo tree lins = do getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int)) getSubtermsMod mo js = do mapM (getInfo (collectSubterms mo)) js - (tree0,_) <- readSTM + (tree0,_) <- get return $ Map.filter (\ (nu,_) -> nu > 1) tree0 where getInfo get fi@(f,i) = case i of @@ -123,12 +123,12 @@ collectSubterms mo t = case t of where collect = collectSubterms mo add t = do - (ts,i) <- readSTM + (ts,i) <- get let ((count,id),next) = case Map.lookup t ts of Just (nu,id) -> ((nu+1,id), i) _ -> ((1, i ), i+1) - writeSTM (Map.insert t (count,id) ts, next) + put (Map.insert t (count,id) ts, next) return t --- only because of composOp operIdent :: Int -> Ident |