diff options
Diffstat (limited to 'src/exper')
| -rw-r--r-- | src/exper/Evaluate.hs | 461 | ||||
| -rw-r--r-- | src/exper/Optimize.hs | 274 |
2 files changed, 0 insertions, 735 deletions
diff --git a/src/exper/Evaluate.hs b/src/exper/Evaluate.hs deleted file mode 100644 index 7c5fb4b6a..000000000 --- a/src/exper/Evaluate.hs +++ /dev/null @@ -1,461 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Evaluate --- 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.Evaluate (appEvalConcrete) where - -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Data.Str -import GF.Grammar.PrGrammar -import GF.Infra.Modules -import GF.Infra.Option -import GF.Grammar.Macros -import GF.Grammar.Lookup -import GF.Grammar.Refresh -import GF.Grammar.PatternMatch -import GF.Grammar.Lockfield (isLockLabel) ---- - -import GF.Grammar.AppPredefined - -import qualified Data.Map as Map - -import Data.List (nub,intersperse) -import Control.Monad (liftM2, liftM) -import Debug.Trace - - -data EEnv = EEnv { - computd :: Map.Map (Ident,Ident) FTerm, - temp :: Int - } - -emptyEEnv = EEnv Map.empty 0 - -lookupComputed :: (Ident,Ident) -> STM EEnv (Maybe FTerm) -lookupComputed mc = do - env <- readSTM - return $ Map.lookup mc $ computd env - -updateComputed :: (Ident,Ident) -> FTerm -> STM EEnv () -updateComputed mc t = updateSTM (\e -> e{computd = Map.insert mc t (computd e)}) - -getTemp :: STM EEnv Ident -getTemp = do - env <- readSTM - updateSTM (\e -> e{temp = temp e + 1}) - return $ identC ("#" ++ show (temp env)) - -data FTerm = - FTC Term - | FTF (Term -> FTerm) - -prFTerm :: Integer -> FTerm -> String -prFTerm i t = case t of - FTC t -> prt t - FTF f -> show i +++ "->" +++ prFTerm (i + 1) (f (EInt i)) - -term2fterm t = case t of - Abs x b -> FTF (\t -> term2fterm (subst [(x,t)] b)) - _ -> FTC t - -traceFTerm c ft = ft ----trace ("\n" ++ prt c +++ "=" +++ take 60 (prFTerm 0 ft)) ft - -fterm2term :: FTerm -> STM EEnv Term -fterm2term t = case t of - FTC t -> return t - FTF f -> do - x <- getTemp - b <- fterm2term $ f (Vr x) - return $ Abs x b - -subst g t = case t of - Vr x -> maybe t id $ lookup x g - _ -> composSafeOp (subst g) t - - -appFTerm :: FTerm -> [Term] -> FTerm -appFTerm ft ts = case (ft,ts) of - (FTF f, x:xs) -> appFTerm (f x) xs - _ -> ft -{- - (FTC _, []) -> ft - (FTC f, [a]) -> case appPredefined (App f a) of - Ok (t,_) -> FTC t - _ -> error $ "error: appFTerm" +++ prFTerm 0 ft +++ unwords (map prt ts) - _ -> error $ "error: appFTerm" +++ prFTerm 0 ft +++ unwords (map prt ts) --} - -apps :: Term -> (Term,[Term]) -apps t = case t of - App f a -> (f',xs ++ [a]) where (f',xs) = apps f - _ -> (t,[]) - -appEvalConcrete gr bt = liftM fst $ appSTM (evalConcrete gr bt) emptyEEnv - -evalConcrete :: SourceGrammar -> BinTree Ident Info -> STM EEnv (BinTree Ident Info) -evalConcrete gr mo = mapMTree evaldef mo where - - evaldef (f,info) = case info of - CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> - evalIn ("\nerror in linearization of function" +++ prt f +++ ":") $ - do - pde' <- case pde of - Yes de -> do - liftM yes $ pEval ty de - _ -> return pde - --- ppr' <- liftM yes $ evalPrintname gr c ppr pde' - return $ (f, CncFun mt pde' ppr) -- only cat in type actually needed - - _ -> return (f,info) - - pEval (context,val) trm = do ---- 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 <- recordExpand val trm1 >>= comp subst - return $ mkAbs vars trm3 - - 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 - - comp g t = case t of - - Q (IC "Predef") _ -> trace ("\nPredef:\n" ++ prt t) $ return t - - Q p c -> do - md <- lookupComputed (p,c) - case md of - Nothing -> do - d <- lookRes (p,c) - updateComputed (p,c) $ traceFTerm c $ term2fterm d - return d - Just d -> fterm2term d >>= comp g - App f a -> case apps t of - (h@(Q p c),xs) | p == IC "Predef" -> do - xs' <- mapM (comp g) xs - (t',b) <- stmErr $ appPredefined (foldl App h xs') - if b then return t' else comp g t' - (h@(Q p c),xs) -> do - xs' <- mapM (comp g) xs - md <- lookupComputed (p,c) - case md of - Just ft -> do - t <- fterm2term $ appFTerm ft xs' - comp g t - Nothing -> do - d <- lookRes (p,c) - let ft = traceFTerm c $ term2fterm d - updateComputed (p,c) ft - t' <- fterm2term $ appFTerm ft xs' - comp g t' - _ -> do - f' <- comp g f - a' <- comp g a - case (f',a') of - (Abs x b,_) -> comp (ext x a' g) b - (QC _ _,_) -> returnC $ App f' a' - (FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants - (_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants - - (Alias _ _ d, _) -> comp g (App d a') - - (S (T i cs) e,_) -> prawitz g i (flip App a') cs e - - _ -> do - (t',b) <- stmErr $ appPredefined (App f' a') - if b then return t' else comp g t' - - - Vr x -> do - t' <- maybe (prtRaise ( - "context" +++ show g +++ ": 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' - - P t l | isLockLabel l -> return $ R [] - ---- a workaround 18/2/2005: take this away and find the reason - ---- why earlier compilation destroys the lock field - - - 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 - (prtRaise (prt t' ++ ": no value for label") l) (comp g . snd) $ - lookup l r - - ExtR a (R b) -> case lookup l b of ----comp g (P (R b) l) of - Just (_,v) -> comp g v - _ -> comp g (P a l) - - S (T i cs) e -> prawitz g i (flip P l) cs e - - _ -> returnC $ P t' l - - S t@(T _ cc) v -> do - v' <- comp g v - case v' of - FV vs -> do - ts' <- mapM (comp g . S t) vs - return $ variants ts' - _ -> case matchPattern cc v' of - Ok (c,g') -> comp (g' ++ g) c - _ | isCan v' -> prtRaise ("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' <- comp g t - v' <- comp g v - case t' of - 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 - - FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants - - V ptyp ts -> do - vs <- stmErr $ allParamValues gr ptyp - ps <- stmErr $ mapM term2patt vs - let cc = zip ps ts - case v' of - FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants - _ -> case matchPattern cc v' of - Ok (c,g') -> comp (g' ++ g) c - _ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t - _ -> return $ S t' v' -- if v' is not canonical - - T _ cc -> case v' of - FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants - _ -> case matchPattern cc v' of - Ok (c,g') -> comp (g' ++ g) c - _ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t - _ -> return $ S t' v' -- if v' is not canonical - - Alias _ _ d -> comp g (S d v') - - S (T i cs) e -> prawitz 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 - (Alias _ _ d, y) -> comp g $ Glue d y - (x, Alias _ _ d) -> comp g $ Glue x d - - (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 - (_,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' <- stmErr $ strsFromTerm ka ----- (Alts _, K a) -> checks [do - x' <- stmErr $ 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 - ] - (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 - - _ -> 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 <- stmErr $ 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 - (Alias _ _ d, _) -> comp g $ ExtR d s' - (_, Alias _ _ d) -> comp g $ Glue r' d - - (R rs, R ss) -> stmErr $ plusRecord r' s' - (RecType rs, RecType ss) -> stmErr $ plusRecType r' s' - _ -> return $ ExtR r' s' - - -- case-expand tables - -- if already expanded, don't expand again - T i@(TComp _) 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 $ T i cs' - - --- this means some extra work; should implement TSh directly - TSh i cs -> comp g $ T i [(p,v) | (ps,v) <- cs, p <- ps] - - T i cs -> do - pty0 <- stmErr $ getTableType i - ptyp <- comp g pty0 - case allParamValues gr ptyp of - Ok vs -> do - - cs' <- mapM (compBranchOpt g) cs - sts <- stmErr $ mapM (matchPattern cs') vs - ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts - ps <- stmErr $ mapM term2patt vs - let ps' = ps --- PT ptyp (head ps) : tail ps - return $ --- V ptyp ts -- to save space, just course of values - 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 - - lookRes (p,c) = case lookupResDefKind gr p c of - Ok (t,_) | noExpand p -> return t - Ok (t,0) -> 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 - - prtRaise s t = raise (s +++ prt t) - - 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 - _ -> compBranch g 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 - --- | argument variables cannot be glued -checkNoArgVars :: Term -> STM EEnv Term -checkNoArgVars t = case t of - Vr (IA _) -> raise $ glueErrorMsg $ prt t - Vr (IAV _) -> raise $ glueErrorMsg $ prt t - _ -> composOp checkNoArgVars t - -glueErrorMsg s = - "Cannot glue (+) term with run-time variable" +++ s ++ "." ++++ - "Use Prelude.bind instead." - -stmErr :: Err a -> STM s a -stmErr e = stm (\s -> do - v <- e - return (v,s) - ) - -evalIn :: String -> STM s a -> STM s a -evalIn msg st = stm $ \s -> case appSTM st s of - Bad e -> Bad $ msg ++++ e - Ok vs -> Ok vs diff --git a/src/exper/Optimize.hs b/src/exper/Optimize.hs deleted file mode 100644 index ff4614700..000000000 --- a/src/exper/Optimize.hs +++ /dev/null @@ -1,274 +0,0 @@ ----------------------------------------------------------------------- --- | --- 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.Compile.Optimize (optimizeModule) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.PrGrammar -import GF.Grammar.Macros -import GF.Grammar.Lookup -import GF.Grammar.Refresh -import GF.Grammar.Compute -import GF.Compile.BackOpt -import GF.Compile.CheckGrammar -import GF.Compile.Update - -import GF.Compile.Evaluate - -import GF.Data.Operations -import GF.Infra.CheckM -import GF.Infra.Option - -import Control.Monad -import Data.List - --- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005. --- only do this for resource: concrete is optimized in gfc form -optimizeModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) -> - Err (Ident,SourceModInfo) -optimizeModule opts ms mo@(_,mi) = case mi of - ModMod m0@(Module mt st fs me ops js) | st == MSComplete && isModRes m0 -> do - mo1 <- evalModule oopts ms mo - return $ 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 - _ -> evalModule oopts ms mo - where - oopts = addOptions opts (iOpts (flagsModule mo)) - optim = maybe "all" id $ getOptVal oopts useOptimizer - -evalModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) -> - Err (Ident,SourceModInfo) -evalModule oopts ms mo@(name,mod) = case mod of - - ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of -{- - -- now: don't optimize resource - - _ | isModRes m0 -> do - let deps = allOperDependencies name js - ids <- topoSortOpers deps - MGrammar (mod' : _) <- foldM evalOp gr ids - return $ mod' --} - MTConcrete a -> do ------ - js0 <- appEvalConcrete gr js - js' <- mapMTree (evalCncInfo oopts gr name a) js0 ---- <- gr0 6/12/2005 - return $ (name, ModMod (Module mt st fs me ops js')) - - _ -> return $ (name,mod) - _ -> return $ (name,mod) - 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) = 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 -> 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 +++ ":") - --- | 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 trm1 >>= comp subst >>= outCase subst - else etaExpand trm1 >>= comp subst - return $ mkAbs vars trm3 - - where - - globalTable = oElem showAll opts --- i -all - - comp g t = {- refreshTerm t >>= -} computeTerm gr g t - - etaExpand t = recordExpand val t --- >>= caseEx -- done by comp - - 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 - |