msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Made mapAssignM more efficient.

Browse Source
This commit is contained in:
bringert
2005-11-11 15:38:00 +00:00
parent 051789bb40
commit 3684eca40b
1 changed files with 6 additions and 12 deletions
Download Patch File Download Diff File Expand all files Collapse all files

18
src/GF/Grammar/Macros.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/10/02 20:50:19 $ -- > CVS $Date: 2005/11/11 16:38:00 $
-- > CVS $Author: aarne $ -- > CVS $Author: bringert $
-- > CVS $Revision: 1.23 $ -- > CVS $Revision: 1.24 $
-- --
-- Macros for constructing and analysing source code terms. -- Macros for constructing and analysing source code terms.
-- --
@@ -24,7 +24,7 @@ import GF.Grammar.Grammar
import GF.Infra.Ident import GF.Infra.Ident
import GF.Grammar.PrGrammar import GF.Grammar.PrGrammar
import Control.Monad (liftM) import Control.Monad (liftM, liftM2)
import Data.Char (isDigit) import Data.Char (isDigit)
firstTypeForm :: Type -> Err (Context, Type) firstTypeForm :: Type -> Err (Context, Type)
@@ -259,14 +259,8 @@ prLabel :: Label -> String
prLabel = prt prLabel = prt
mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))] mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
mapAssignM f ltvs = do mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv))
let (ls,tvs) = unzip ltvs where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v)
(ts, vs) = unzip tvs
ts' <- mapM (\t -> case t of
Nothing -> return Nothing
Just y -> f y >>= return . Just) ts
vs' <- mapM f vs
return (zip ls (zip ts' vs'))
mkRecordN :: Int -> (Int -> Label) -> [Term] -> Term mkRecordN :: Int -> (Int -> Label) -> [Term] -> Term
mkRecordN int lab typs = R [ assign (lab i) t | (i,t) <- zip [int..] typs] mkRecordN int lab typs = R [ assign (lab i) t | (i,t) <- zip [int..] typs]