diff options
| -rw-r--r-- | src/GF/Devel/Compile/Compile.hs | 15 | ||||
| -rw-r--r-- | src/GF/Devel/Compile/Optimize.hs | 319 | ||||
| -rw-r--r-- | src/GF/Devel/Grammar/Compute.hs | 380 | ||||
| -rw-r--r-- | src/GF/Devel/Grammar/Macros.hs | 78 |
4 files changed, 785 insertions, 7 deletions
diff --git a/src/GF/Devel/Compile/Compile.hs b/src/GF/Devel/Compile/Compile.hs index 9c4079519..cb1d87a60 100644 --- a/src/GF/Devel/Compile/Compile.hs +++ b/src/GF/Devel/Compile/Compile.hs @@ -6,14 +6,13 @@ import GF.Devel.Compile.Extend import GF.Devel.Compile.Rename import GF.Devel.Compile.CheckGrammar import GF.Devel.Compile.Refresh -----import GF.Devel.Optimize +import GF.Devel.Compile.Optimize ----import GF.Devel.OptimizeGF import GF.Devel.Grammar.Terms import GF.Devel.Grammar.Modules import GF.Devel.Grammar.Judgements import GF.Infra.Ident -import GF.Infra.CompactPrint import GF.Devel.Grammar.PrGF ----import GF.Grammar.Lookup import GF.Devel.ReadFiles @@ -41,7 +40,7 @@ intermOut opts opt s = if oElem opt opts then else return () prMod :: SourceModule -> String -prMod = compactPrint . prModule +prMod = prModule -- | environment variable for grammar search path gfGrammarPathVar = "GF_GRAMMAR_PATH" @@ -146,10 +145,10 @@ compileSourceModule opts env@(k,gr) mo@(i,mi) = do putpp = putPointEsil opts - moe <- ioeErr $ extendModule gr mo + moe <- putpp " extending" $ ioeErr $ extendModule gr mo intermOut opts (iOpt "show_extend") (prMod moe) - mor <- ioeErr $ renameModule gr moe + mor <- putpp " renaming" $ ioeErr $ renameModule gr moe intermOut opts (iOpt "show_rename") (prMod mor) (moc,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule gr mor @@ -159,9 +158,11 @@ compileSourceModule opts env@(k,gr) mo@(i,mi) = do (k',mox) <- putpp " refreshing " $ ioeErr $ refreshModule k moc intermOut opts (iOpt "show_refresh") (prMod mox) + moo <- putpp " optimizing " $ ioeErr $ optimizeModule opts gr mox + intermOut opts (iOpt "show_optimize") (prMod moo) - return (k,mox) ---- + return (k,moo) ---- {- ---- @@ -196,7 +197,7 @@ generateModuleCode opts path minfo@(name,info) = do let minfo2 = minfo1 let (file,out) = (gfoFile pname, prGrammar (MGrammar [minfo2])) - putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ compactPrint out + putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ out return minfo2 where diff --git a/src/GF/Devel/Compile/Optimize.hs b/src/GF/Devel/Compile/Optimize.hs new file mode 100644 index 000000000..311715b19 --- /dev/null +++ b/src/GF/Devel/Compile/Optimize.hs @@ -0,0 +1,319 @@ +---------------------------------------------------------------------- +-- | +-- Module : Optimize +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/16 13:56:13 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.18 $ +-- +-- Top-level partial evaluation for GF source modules. +----------------------------------------------------------------------------- + +module GF.Devel.Compile.Optimize (optimizeModule) where + +import GF.Devel.Grammar.Modules +--import GF.Devel.Grammar.Judgements +--import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Macros +--import GF.Devel.Grammar.PrGF +import GF.Devel.Grammar.Compute + +--import GF.Infra.Ident + +--import GF.Grammar.Lookup +--import GF.Grammar.Refresh + +--import GF.Compile.BackOpt +--import GF.Devel.CheckGrammar +--import GF.Compile.Update + + +--import GF.Infra.CheckM +import GF.Infra.Option ---- + +import GF.Data.Operations + +import Control.Monad +import Data.List + +import Debug.Trace + + +optimizeModule :: Options -> GF -> SourceModule -> Err SourceModule +optimizeModule opts gf sm@(m,mo) = case mtype mo of + MTConcrete _ -> opt sm + MTInstance _ -> opt sm + MTGrammar -> opt sm + _ -> return sm + where + opt (m,mo) = do + mo' <- termOpModule (computeTerm gf) mo + return (m,mo') + + + +{- + +-- conditional trace + +prtIf :: (Print a) => Bool -> a -> a +prtIf b t = if b then trace (" " ++ prt t) t else t + +-- | partial evaluation of concrete syntax. +-- AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005 -- 7/12/2007 + +type EEnv = () --- not used + +-- only do this for resource: concrete is optimized in gfc form + + + + =mse@(ms,eenv) mo@(_,mi) = case mi of + ModMod m0@(Module mt st fs me ops js) | + st == MSComplete && isModRes m0 && not (oElem oEval oopts)-> do + (mo1,_) <- evalModule oopts mse mo + let + mo2 = case optim of + "parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing + "values" -> shareModule valOpt mo1 -- tables as courses-of-values + "share" -> shareModule shareOpt mo1 -- sharing of branches + "all" -> shareModule allOpt mo1 -- first parametrize then values + "none" -> mo1 -- no optimization + _ -> mo1 -- none; default for src + return (mo2,eenv) + _ -> evalModule oopts mse mo + where + oopts = addOptions opts (iOpts (flagsModule mo)) + optim = maybe "all" id $ getOptVal oopts useOptimizer + +evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) -> + Err ((Ident,SourceModInfo),EEnv) +evalModule oopts (ms,eenv) mo@(name,mod) = case mod of + + ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of + _ | isModRes m0 && not (oElem oEval oopts) -> do + let deps = allOperDependencies name js + ids <- topoSortOpers deps + MGrammar (mod' : _) <- foldM evalOp gr ids + return $ (mod',eenv) + + MTConcrete a -> do + js' <- mapMTree (evalCncInfo oopts gr name a) js ---- <- gr0 6/12/2005 + return $ ((name, ModMod (Module mt st fs me ops js')),eenv) + + _ -> return $ ((name,mod),eenv) + _ -> return $ ((name,mod),eenv) + where + gr0 = MGrammar $ ms + gr = MGrammar $ (name,mod) : ms + + evalOp g@(MGrammar ((_, ModMod m) : _)) i = do + info <- lookupTree prt i $ jments m + info' <- evalResInfo oopts gr (i,info) + return $ updateRes g name i info' + +-- | only operations need be compiled in a resource, and this is local to each +-- definition since the module is traversed in topological order +evalResInfo :: Options -> SourceGrammar -> (Ident,Info) -> Err Info +evalResInfo oopts gr (c,info) = case info of + + ResOper pty pde -> eIn "operation" $ do + pde' <- case pde of + Yes de | optres -> liftM yes $ comp de + _ -> return pde + return $ ResOper pty pde' + + _ -> return info + where + comp = if optres then computeConcrete gr else computeConcreteRec gr + eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") + optim = maybe "all" id $ getOptVal oopts useOptimizer + optres = case optim of + "noexpand" -> False + _ -> True + + +evalCncInfo :: + Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info) +evalCncInfo opts gr cnc abs (c,info) = do + + seq (prtIf (oElem beVerbose opts) c) $ return () + + errIn ("optimizing" +++ prt c) $ case info of + + CncCat ptyp pde ppr -> do + pde' <- case (ptyp,pde) of + (Yes typ, Yes de) -> + liftM yes $ pEval ([(strVar, typeStr)], typ) de + (Yes typ, Nope) -> + liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(strVar, typeStr)],typ) + (May b, Nope) -> + return $ May b + _ -> return pde -- indirection + + ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c) + + return (c, CncCat ptyp pde' ppr') + + CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> + eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do + pde' <- case pde of + Yes de | notNewEval -> do + liftM yes $ pEval ty de + + _ -> return pde + ppr' <- liftM yes $ evalPrintname gr c ppr pde' + return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed + + _ -> return (c,info) + where + pEval = partEval opts gr + eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") + notNewEval = not (oElem oEval opts) + +-- | the main function for compiling linearizations +partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term +partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do + let vars = map fst context + args = map Vr vars + subst = [(v, Vr v) | v <- vars] + trm1 = mkApp trm args + trm3 <- if globalTable + then etaExpand subst trm1 >>= outCase subst + else etaExpand subst trm1 + return $ mkAbs vars trm3 + + where + + globalTable = oElem showAll opts --- i -all + + comp g t = ---- refreshTerm t >>= + computeTerm gr g t + + etaExpand su t = do + t' <- comp su t + case t' of + R _ | rightType t' -> comp su t' --- return t' wo noexpand... + _ -> recordExpand val t' >>= comp su + -- don't eta expand records of right length (correct by type checking) + rightType t = case (t,val) of + (R rs, RecType ts) -> length rs == length ts + _ -> False + + outCase subst t = do + pts <- getParams context + let (args,ptyps) = unzip $ filter (flip occur t . fst) pts + if null args + then return t + else do + let argtyp = RecType $ tuple2recordType ptyps + let pvars = map (Vr . zIdent . prt) args -- gets eliminated + patt <- term2patt $ R $ tuple2record $ pvars + let t' = replace (zip args pvars) t + t1 <- comp subst $ T (TTyped argtyp) [(patt, t')] + return $ S t1 $ R $ tuple2record args + + --- notice: this assumes that all lin types follow the "old JFP style" + getParams = liftM concat . mapM getParam + getParam (argv,RecType rs) = return + [(P (Vr argv) lab, ptyp) | (lab,ptyp) <- rs, not (isLinLabel lab)] + ---getParam (_,ty) | ty==typeStr = return [] --- in lindef + getParam (av,ty) = + Bad ("record type expected not" +++ prt ty +++ "for" +++ prt av) + --- all lin types are rec types + + replace :: [(Term,Term)] -> Term -> Term + replace reps trm = case trm of + -- this is the important case + P _ _ -> maybe trm id $ lookup trm reps + _ -> composSafeOp (replace reps) trm + + occur t trm = case trm of + + -- this is the important case + P _ _ -> t == trm + S x y -> occur t y || occur t x + App f x -> occur t x || occur t f + Abs _ f -> occur t f + R rs -> any (occur t) (map (snd . snd) rs) + T _ cs -> any (occur t) (map snd cs) + C x y -> occur t x || occur t y + Glue x y -> occur t x || occur t y + ExtR x y -> occur t x || occur t y + FV ts -> any (occur t) ts + V _ ts -> any (occur t) ts + Let (_,(_,x)) y -> occur t x || occur t y + _ -> False + + +-- here we must be careful not to reduce +-- variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}} +-- {s = variants {"Auto" ; "Wagen"} ; g = variants {N ; M}} ; + +recordExpand :: Type -> Term -> Err Term +recordExpand typ trm = case unComputed typ of + RecType tys -> case trm of + FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs] + _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys] + _ -> return trm + + +-- | auxiliaries for compiling the resource + +mkLinDefault :: SourceGrammar -> Type -> Err Term +mkLinDefault gr typ = do + case unComputed typ of + RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign) + _ -> prtBad "linearization type must be a record type, not" typ + where + mkDefField typ = case unComputed typ of + Table p t -> do + t' <- mkDefField t + let T _ cs = mkWildCases t' + return $ T (TWild p) cs + Sort "Str" -> return $ Vr strVar + QC q p -> lookupFirstTag gr q p + RecType r -> do + let (ls,ts) = unzip r + ts' <- mapM mkDefField ts + return $ R $ [assign l t | (l,t) <- zip ls ts'] + _ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val + _ -> prtBad "linearization type field cannot be" typ + +-- | Form the printname: if given, compute. If not, use the computed +-- lin for functions, cat name for cats (dispatch made in evalCncDef above). +--- We cannot use linearization at this stage, since we do not know the +--- defaults we would need for question marks - and we're not yet in canon. +evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term +evalPrintname gr c ppr lin = + case ppr of + Yes pr -> comp pr + _ -> case lin of + Yes t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm + _ -> return $ K $ prt c ---- + where + comp = computeConcrete gr + + oneBranch t = case t of + Abs _ b -> oneBranch b + R (r:_) -> oneBranch $ snd $ snd r + T _ (c:_) -> oneBranch $ snd c + V _ (c:_) -> oneBranch c + FV (t:_) -> oneBranch t + C x y -> C (oneBranch x) (oneBranch y) + S x _ -> oneBranch x + P x _ -> oneBranch x + Alts (d,_) -> oneBranch d + _ -> t + + --- very unclean cleaner + clean s = case s of + '+':'+':' ':cs -> clean cs + '"':cs -> clean cs + c:cs -> c: clean cs + _ -> s + +-} diff --git a/src/GF/Devel/Grammar/Compute.hs b/src/GF/Devel/Grammar/Compute.hs new file mode 100644 index 000000000..82417ec99 --- /dev/null +++ b/src/GF/Devel/Grammar/Compute.hs @@ -0,0 +1,380 @@ +---------------------------------------------------------------------- +-- | +-- Module : 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.Devel.Grammar.Compute ( + computeTerm, + computeTermCont, + computeTermRec + ) where + +import GF.Devel.Grammar.Modules +import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Macros +import GF.Devel.Grammar.Lookup +import GF.Devel.Grammar.PrGF +import GF.Devel.Grammar.PatternMatch +import GF.Devel.Grammar.AppPredefined + +import GF.Infra.Ident +import GF.Infra.Option + +--import GF.Grammar.Refresh +--import GF.Grammar.Lockfield (isLockLabel) ---- + +import GF.Data.Str ---- +import GF.Data.Operations + +import Data.List (nub,intersperse) +import Control.Monad (liftM2, liftM) + +-- | computation of concrete syntax terms into normal form +-- used mainly for partial evaluation +computeTerm :: GF -> Term -> Err Term +computeTerm g t = {- refreshTerm t >>= -} computeTermCont g [] t +computeTermRec g t = {- refreshTerm t >>= -} computeTermOpt True g [] t + +computeTermCont :: GF -> Substitution -> Term -> Err Term +computeTermCont = 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 -> GF -> Substitution -> Term -> Err Term +computeTermOpt rec gr = comp where + + comp g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging + case t of + + Q (IC "Predef") _ -> return t + Q p c -> look p c + + -- if computed do nothing + ---- Computed t' -> return $ unComputed t' + + Vr x -> do + t' <- maybe (prtBad ("no value given to variable") x) return $ lookup x g + case t' of + _ | t == t' -> return t + _ -> comp g t' + + Abs x b -> do + b' <- comp (ext x (Vr x) g) b + return $ Abs x b' + + Let (x,(_,a)) b -> do + a' <- comp g a + comp (ext x a' g) b + + Prod x a b -> do + a' <- comp g a + b' <- comp (ext x (Vr x) g) b + return $ Prod x a' b' + + -- beta-convert + App f a -> do + f' <- comp g f + a' <- comp g a + case (f',a') of + (Abs x b, FV as) -> + 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 + (QC _ _,_) -> returnC $ App f' a' + + (S (T i cs) e,_) -> prawitz g i (flip App a') cs e + (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' + + P t l -> do + t' <- comp g t + case t' of + FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants + R r -> maybe (prtBad "no value for label" l) (comp g . snd) $ + lookup l $ reverse r + + ExtR a (R b) -> + 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 + S (V i cs) e -> prawitzV g i (flip P l) cs e + + _ -> returnC $ P t' l + + PI t l i -> comp g $ P t l ----- + + S t@(T ti cc) v -> do + v' <- comp g v + case v' of + FV vs -> do + ts' <- mapM (comp g . S t) vs + return $ variants ts' + _ -> case ti of +{- + TComp _ -> do + case term2patt v' of + Ok p' -> case lookup p' cc of + Just u -> comp g u + _ -> do + t' <- comp g t + return $ S t' v' -- if v' is not canonical + _ -> do + t' <- comp g t + return $ S t' v' +-} + _ -> case matchPattern cc v' of + Ok (c,g') -> comp (g' ++ g) c + _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t + _ -> do + t' <- comp g t + return $ S t' v' -- if v' is not canonical + + + S t v -> do + + t' <- case t of +---- why not? ResFin.Agr "has no values" +---- T (TComp _) _ -> return t +---- V _ _ -> return t + _ -> comp g t + + v' <- comp g v + + case v' of + FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants + _ -> case t' of + FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants + + T _ [(PV IW,c)] -> comp g c --- an optimization + T _ [(PT _ (PV IW),c)] -> comp g c + + T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization + 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 + vs <- allParamValues gr ptyp + case lookup v' (zip vs [0 .. length vs - 1]) of + Just i -> comp g $ ts !! i +----- _ -> prtBad "selection" $ S t' v' -- debug + _ -> return $ S t' v' -- if v' is not canonical + + T (TComp _) cs -> do + case term2patt v' of + Ok p' -> case lookup p' cs of + Just u -> comp g u + _ -> return $ S t' v' -- if v' is not canonical + _ -> return $ S t' v' + + T _ cc -> case matchPattern cc v' of + Ok (c,g') -> comp (g' ++ g) c + _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t + _ -> return $ S t' v' -- if v' is not canonical + + + S (T i cs) e -> prawitz g i (flip S v') cs e + S (V i cs) e -> prawitzV g i (flip S v') cs e + _ -> returnC $ S t' v' + + -- normalize away empty tokens + K "" -> return Empty + + -- glue if you can + Glue x0 y0 -> do + x <- comp g x0 + y <- comp g y0 + case (x,y) of + (FV ks,_) -> do + kys <- mapM (comp g . flip Glue y) ks + return $ variants kys + (_,FV ks) -> do + xks <- mapM (comp g . Glue x) ks + return $ variants xks + + (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e + (s, S (T i cs) e) -> prawitz g i (Glue s) cs e + (S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e + (s, S (V i cs) e) -> prawitzV g i (Glue s) cs e + (_,Empty) -> return x + (Empty,_) -> return y + (K a, K b) -> return $ K (a ++ b) + (_, Alts (d,vs)) -> do +---- (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 + 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) + + _ -> do + mapM_ checkNoArgVars [x,y] + r <- composOp (comp g) t + returnC r + + Alts _ -> do + r <- composOp (comp g) t + returnC r + + -- remove empty + C a b -> do + a' <- comp g a + b' <- comp g b + case (a',b') of + (Alts _, K a) -> checks [do + as <- strsFromTerm a' -- this may fail when compiling opers + return $ variants [ + foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as] + , + return $ C a' b' + ] + (Empty,_) -> returnC b' + (_,Empty) -> returnC a' + _ -> returnC $ C a' b' + + -- reduce free variation as much as you can + FV ts -> mapM (comp g) ts >>= returnC . variants + + -- merge record extensions if you can + ExtR r s -> do + 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' + + -- case-expand tables + -- if already expanded, don't expand again + 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' + + T i cs -> do + pty0 <- getTableType i + ptyp <- comp g pty0 + case allParamValues gr ptyp of + Ok vs -> do + + cs' <- mapM (compBranchOpt g) cs ---- why is this needed?? + 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 ---- why doesn't this work?? + return $ T (TComp ptyp) (zip ps' ts) + _ -> do + cs' <- mapM (compBranch g) cs + return $ T i cs' -- happens with variable types + + -- otherwise go ahead + _ -> composOp (comp g) t >>= returnC + + where + + look p c + | rec = lookupOperDef gr p c >>= comp [] + | otherwise = lookupOperDef gr p c + +{- + look p c = case lookupResDefKind gr p c of + Ok (t,_) | noExpand p || rec -> comp [] t + Ok (t,_) -> return t + Bad s -> raise s + + noExpand p = errVal False $ do + mo <- lookupModMod gr p + return $ case getOptVal (iOpts (flags mo)) useOptimizer of + Just "noexpand" -> True + _ -> False +-} + + ext x a g = (x,a):g + + returnC = return --- . computed + + variants ts = case nub ts of + [t] -> t + ts -> FV ts + + isCan v = case v of + Con _ -> True + QC _ _ -> True + App f a -> isCan f && isCan a + R rs -> all (isCan . snd . snd) rs + _ -> False + + compBranch g (p,v) = do + let g' = contP p ++ g + 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 + + 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 + +-- | argument variables cannot be glued +checkNoArgVars :: Term -> Err Term +checkNoArgVars t = case t of + Vr (IA _) -> Bad $ glueErrorMsg $ prt t + Vr (IAV _) -> Bad $ glueErrorMsg $ prt t + _ -> composOp checkNoArgVars t + +glueErrorMsg s = + "Cannot glue (+) term with run-time variable" +++ s ++ "." ++++ + "Use Prelude.bind instead." diff --git a/src/GF/Devel/Grammar/Macros.hs b/src/GF/Devel/Grammar/Macros.hs index db84fc7a4..0eebfda16 100644 --- a/src/GF/Devel/Grammar/Macros.hs +++ b/src/GF/Devel/Grammar/Macros.hs @@ -5,6 +5,7 @@ import GF.Devel.Grammar.Judgements import GF.Devel.Grammar.Modules import GF.Infra.Ident +import GF.Data.Str import GF.Data.Operations import qualified Data.Map as Map @@ -120,6 +121,9 @@ assign l t = (l,(Nothing,t)) assignT :: Label -> Type -> Term -> Assign assignT l a t = (l,(Just a,t)) +unzipR :: [Assign] -> ([Label],[Term]) +unzipR r = (ls, map snd ts) where (ls,ts) = unzip r + mkDecl :: Term -> Decl mkDecl typ = (wildIdent, typ) @@ -389,6 +393,80 @@ patt2term pt = case pt of PNeg a -> appc "-" [(patt2term a)] --- an encoding +term2patt :: Term -> Err Patt +term2patt trm = case Ok (termForm trm) of + Ok ([], Vr x, []) -> return (PV x) + Ok ([], QC p c, aa) -> do + aa' <- mapM term2patt aa + return (PP p c aa') + Ok ([], R r, []) -> do + let (ll,aa) = unzipR r + aa' <- mapM term2patt aa + return (PR (zip ll aa')) + Ok ([],EInt i,[]) -> return $ PInt i + Ok ([],EFloat i,[]) -> return $ PFloat i + Ok ([],K s, []) -> return $ PString s + +--- encodings due to excessive use of term-patt convs. AR 7/1/2005 + Ok ([], Con (IC "@"), [Vr a,b]) -> do + b' <- term2patt b + return (PAs a b') + Ok ([], Con (IC "-"), [a]) -> do + a' <- term2patt a + return (PNeg a') + Ok ([], Con (IC "*"), [a]) -> do + a' <- term2patt a + return (PRep a') + Ok ([], Con (IC "+"), [a,b]) -> do + a' <- term2patt a + b' <- term2patt b + return (PSeq a' b') + Ok ([], Con (IC "|"), [a,b]) -> do + a' <- term2patt a + b' <- term2patt b + return (PAlt a' b') + + Ok ([], Con c, aa) -> do + aa' <- mapM term2patt aa + return (PC c aa') + + _ -> Bad $ "no pattern corresponds to term" +++ show trm + +getTableType :: TInfo -> Err Type +getTableType i = case i of + TTyped ty -> return ty + TComp ty -> return ty + TWild ty -> return ty + _ -> Bad "the table is untyped" + +-- | to get a string from a term that represents a sequence of terminals +strsFromTerm :: Term -> Err [Str] +strsFromTerm t = case t of + K s -> return [str s] + Empty -> return [str []] + C s t -> do + s' <- strsFromTerm s + t' <- strsFromTerm t + return [plusStr x y | x <- s', y <- t'] + Glue s t -> do + s' <- strsFromTerm s + t' <- strsFromTerm t + return [glueStr x y | x <- s', y <- t'] + Alts (d,vs) -> do + d0 <- strsFromTerm d + v0 <- mapM (strsFromTerm . fst) vs + c0 <- mapM (strsFromTerm . snd) vs + let vs' = zip v0 c0 + return [strTok (str2strings def) vars | + def <- d0, + vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | + vv <- combinations v0] + ] + FV ts -> mapM strsFromTerm ts >>= return . concat + _ -> Bad $ "cannot get Str from term" +++ show t + + + ---- given in lib? mapMapM :: (Monad m, Ord k) => (v -> m v) -> Map.Map k v -> m (Map.Map k v) |