diff options
Diffstat (limited to 'src-3.0/GF/Compile')
| -rw-r--r-- | src-3.0/GF/Compile/CheckGrammar.hs | 1078 | ||||
| -rw-r--r-- | src-3.0/GF/Compile/Compile.hs | 401 | ||||
| -rw-r--r-- | src-3.0/GF/Compile/Evaluate.hs | 477 | ||||
| -rw-r--r-- | src-3.0/GF/Compile/Flatten.hs | 92 | ||||
| -rw-r--r-- | src-3.0/GF/Compile/GetGrammar.hs | 146 | ||||
| -rw-r--r-- | src-3.0/GF/Compile/GrammarToCanon.hs | 293 | ||||
| -rw-r--r-- | src-3.0/GF/Compile/MkConcrete.hs | 154 | ||||
| -rw-r--r-- | src-3.0/GF/Compile/MkResource.hs | 128 | ||||
| -rw-r--r-- | src-3.0/GF/Compile/MkUnion.hs | 83 | ||||
| -rw-r--r-- | src-3.0/GF/Compile/NewRename.hs | 294 | ||||
| -rw-r--r-- | src-3.0/GF/Compile/NoParse.hs | 49 | ||||
| -rw-r--r-- | src-3.0/GF/Compile/Optimize.hs | 300 | ||||
| -rw-r--r-- | src-3.0/GF/Compile/PGrammar.hs | 77 | ||||
| -rw-r--r-- | src-3.0/GF/Compile/PrOld.hs | 84 | ||||
| -rw-r--r-- | src-3.0/GF/Compile/ShellState.hs | 568 | ||||
| -rw-r--r-- | src-3.0/GF/Compile/Wordlist.hs | 108 |
16 files changed, 0 insertions, 4332 deletions
diff --git a/src-3.0/GF/Compile/CheckGrammar.hs b/src-3.0/GF/Compile/CheckGrammar.hs deleted file mode 100644 index b33d11017..000000000 --- a/src-3.0/GF/Compile/CheckGrammar.hs +++ /dev/null @@ -1,1078 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CheckGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:33 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.31 $ --- --- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003 --- --- type checking also does the following modifications: --- --- - types of operations and local constants are inferred and put in place --- --- - both these types and linearization types are computed --- --- - tables are type-annotated ------------------------------------------------------------------------------ - -module GF.Compile.CheckGrammar ( - showCheckModule, justCheckLTerm, allOperDependencies, topoSortOpers) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.Refresh ---- - -import GF.Grammar.TypeCheck -import GF.Grammar.Values (cPredefAbs) --- - -import GF.Grammar.PrGrammar -import GF.Grammar.Lookup -import GF.Grammar.LookAbs -import GF.Grammar.Macros -import GF.Grammar.ReservedWords ---- -import GF.Grammar.PatternMatch -import GF.Grammar.AppPredefined -import GF.Grammar.Lockfield (isLockLabel) - -import GF.Data.Operations -import GF.Infra.CheckM - -import Data.List -import qualified Data.Set as Set -import qualified Data.Map as Map -import Control.Monad -import Debug.Trace --- - - -showCheckModule :: [SourceModule] -> SourceModule -> Err ([SourceModule],String) -showCheckModule mos m = do - (st,(_,msg)) <- checkStart $ checkModule mos m - return (st, unlines $ reverse msg) - --- | checking is performed in the dependency order of modules -checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule] -checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of - - ModMod mo@(Module mt st fs me ops js) -> do - checkRestrictedInheritance ms (name, mo) - js' <- case mt of - MTAbstract -> mapMTree (checkAbsInfo gr name) js - - MTTransfer a b -> mapMTree (checkAbsInfo gr name) js - - MTResource -> mapMTree (checkResInfo gr name) js - - MTConcrete a -> do - checkErr $ topoSortOpers $ allOperDependencies name js - ModMod abs <- checkErr $ lookupModule gr a - js1 <- checkCompleteGrammar abs mo - mapMTree (checkCncInfo gr name (a,abs)) js1 - - MTInterface -> mapMTree (checkResInfo gr name) js - - MTInstance a -> do - ModMod abs <- checkErr $ lookupModule gr a - -- checkCompleteInstance abs mo -- this is done in Rebuild - mapMTree (checkResInfo gr name) js - - return $ (name, ModMod (Module mt st fs me ops js')) : ms - - _ -> return $ (name,mod) : ms - where - gr = MGrammar $ (name,mod):ms - --- check if restricted inheritance modules are still coherent --- i.e. that the defs of remaining names don't depend on omitted names ----checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check () -checkRestrictedInheritance mos (name,mo) = do - let irs = [ii | ii@(_,mi) <- extend mo, mi /= MIAll] -- names with restr. inh. - let mrs = [((i,m),mi) | (i,ModMod m) <- mos, Just mi <- [lookup i irs]] - -- the restr. modules themself, with restr. infos - mapM_ checkRem mrs - where - checkRem ((i,m),mi) = do - let (incl,excl) = partition (isInherited mi) (map fst (tree2list (jments m))) - let incld c = Set.member c (Set.fromList incl) - let illegal c = Set.member c (Set.fromList excl) - let illegals = [(f,is) | - (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)] - case illegals of - [] -> return () - cs -> fail $ "In inherited module" +++ prt i ++ - ", dependence of excluded constants:" ++++ - unlines [" " ++ prt f +++ "on" +++ unwords (map prt is) | - (f,is) <- cs] - allDeps = ---- transClosure $ Map.fromList $ - concatMap (allDependencies (const True)) - [jments m | (_,ModMod m) <- mos] - transClosure ds = ds ---- TODO: check in deeper modules - --- | check if a term is typable -justCheckLTerm :: SourceGrammar -> Term -> Err Term -justCheckLTerm src t = do - ((t',_),_) <- checkStart (inferLType src t) - return t' - -checkAbsInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) -checkAbsInfo st m (c,info) = do ----- checkReservedId c - case info of - AbsCat (Yes cont) _ -> mkCheck "category" $ - checkContext st cont ---- also cstrs - AbsFun (Yes typ0) md -> do - typ <- compAbsTyp [] typ0 -- to calculate let definitions - mkCheck "type of function" $ checkTyp st typ - md' <- case md of - Yes d -> do - let d' = elimTables d - mkCheckWarn "definition of function" $ checkEquation st (m,c) d' - return $ Yes d' - _ -> return md - return $ (c,AbsFun (Yes typ) md') - _ -> return (c,info) - where - mkCheck cat ss = case ss of - [] -> return (c,info) - ["[]"] -> return (c,info) ---- - _ -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c - ---- temporary solution when tc of defs is incomplete - mkCheckWarn cat ss = case ss of - [] -> return (c,info) - ["[]"] -> return (c,info) ---- - _ -> checkWarn (unlines ss ++++ "in" +++ cat +++ prt c) >> return (c,info) - compAbsTyp g t = case t of - Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g - Let (x,(_,a)) b -> do - a' <- compAbsTyp g a - compAbsTyp ((x, a'):g) b - Prod x a b -> do - a' <- compAbsTyp g a - b' <- compAbsTyp ((x,Vr x):g) b - return $ Prod x a' b' - Abs _ _ -> return t - _ -> composOp (compAbsTyp g) t - - elimTables e = case e of - S t a -> elimSel (elimTables t) (elimTables a) - T _ cs -> Eqs [(elimPatt p, elimTables t) | (p,t) <- cs] - _ -> composSafeOp elimTables e - elimPatt p = case p of - PR lps -> map snd lps - _ -> [p] - elimSel t a = case a of - R fs -> mkApp t (map (snd . snd) fs) - _ -> mkApp t [a] - -checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check (BinTree Ident Info) -checkCompleteGrammar abs cnc = do - let js = jments cnc - let fs = tree2list $ jments abs - foldM checkOne js fs - where - checkOne js i@(c,info) = case info of - AbsFun (Yes _) _ -> case lookupIdent c js of - Ok _ -> return js - _ -> do - checkWarn $ "WARNING: no linearization of" +++ prt c - return js - AbsCat (Yes _) _ -> case lookupIdent c js of - Ok (AnyInd _ _) -> return js - Ok (CncCat (Yes _) _ _) -> return js - Ok (CncCat _ mt mp) -> do - checkWarn $ - "Warning: no linearization type for" +++ prt c ++ - ", inserting default {s : Str}" - return $ updateTree (c,CncCat (Yes defLinType) mt mp) js - _ -> do - checkWarn $ - "Warning: no linearization type for" +++ prt c ++ - ", inserting default {s : Str}" - return $ updateTree (c,CncCat (Yes defLinType) nope nope) js - _ -> return js - --- | General Principle: only Yes-values are checked. --- A May-value has always been checked in its origin module. -checkResInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) -checkResInfo gr mo (c,info) = do - checkReservedId c - case info of - ResOper pty pde -> chIn "operation" $ do - (pty', pde') <- case (pty,pde) of - (Yes ty, Yes de) -> do - ty' <- check ty typeType >>= comp . fst - (de',_) <- check de ty' - return (Yes ty', Yes de') - (_, Yes de) -> do - (de',ty') <- infer de - return (Yes ty', Yes de') - (_,Nope) -> do - checkWarn "No definition given to oper" - return (pty,pde) - _ -> return (pty, pde) --- other cases are uninteresting - return (c, ResOper pty' pde') - - ResOverload tysts -> chIn "overloading" $ do - tysts' <- mapM (uncurry $ flip check) tysts - let tysts2 = [(y,x) | (x,y) <- tysts'] - --- this can only be a partial guarantee, since matching - --- with value type is only possible if expected type is given - checkUniq $ - sort [t : map snd xs | (x,_) <- tysts2, Ok (xs,t) <- [typeFormCnc x]] - return (c,ResOverload tysts2) - - ResParam (Yes (pcs,_)) -> chIn "parameter type" $ do ----- mapM ((mapM (computeLType gr . snd)) . snd) pcs - mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs - ts <- checkErr $ lookupParamValues gr mo c - return (c,ResParam (Yes (pcs, Just ts))) - - _ -> return (c,info) - where - infer = inferLType gr - check = checkLType gr - chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") - comp = computeLType gr - - checkUniq xss = case xss of - x:y:xs - | x == y -> raise $ "ambiguous for argument list" +++ - unwords (map (prtType gr) x) - | otherwise -> checkUniq $ y:xs - _ -> return () - - -checkCncInfo :: SourceGrammar -> Ident -> (Ident,SourceAbs) -> - (Ident,Info) -> Check (Ident,Info) -checkCncInfo gr m (a,abs) (c,info) = do - checkReservedId c - case info of - - CncFun _ (Yes trm) mpr -> chIn "linearization of" $ do - typ <- checkErr $ lookupFunTypeSrc gr a c - cat0 <- checkErr $ valCat typ - (cont,val) <- linTypeOfType gr m typ -- creates arg vars - (trm',_) <- check trm (mkFunType (map snd cont) val) -- erases arg vars - checkPrintname gr mpr - cat <- return $ snd cat0 - return (c, CncFun (Just (cat,(cont,val))) (Yes trm') mpr) - -- cat for cf, typ for pe - - CncCat (Yes typ) mdef mpr -> chIn "linearization type of" $ do - checkErr $ lookupCatContextSrc gr a c - typ' <- checkIfLinType gr typ - mdef' <- case mdef of - Yes def -> do - (def',_) <- checkLType gr def (mkFunType [typeStr] typ) - return $ Yes def' - _ -> return mdef - checkPrintname gr mpr - return (c,CncCat (Yes typ') mdef' mpr) - - _ -> checkResInfo gr m (c,info) - - where - env = gr - infer = inferLType gr - comp = computeLType gr - check = checkLType gr - chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") - -checkIfParType :: SourceGrammar -> Type -> Check () -checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType typ) - where - isParType ty = True ---- -{- case ty of - Cn typ -> case lookupConcrete st typ of - Ok (CncParType _ _ _) -> True - Ok (CncOper _ ty' _) -> isParType ty' - _ -> False - Q p t -> case lookupInPackage st (p,t) of - Ok (CncParType _ _ _) -> True - _ -> False - RecType r -> all (isParType . snd) r - _ -> False --} - -checkIfStrType :: SourceGrammar -> Type -> Check () -checkIfStrType st typ = case typ of - Table arg val -> do - checkIfParType st arg - checkIfStrType st val - _ | typ == typeStr -> return () - _ -> prtFail "not a string type" typ - - -checkIfLinType :: SourceGrammar -> Type -> Check Type -checkIfLinType st typ0 = do - typ <- computeLType st typ0 - case typ of - RecType r -> do - let (lins,ihs) = partition (isLinLabel .fst) r - --- checkErr $ checkUnique $ map fst r - mapM_ checkInh ihs - mapM_ checkLin lins - _ -> prtFail "a linearization type must be a record type instead of" typ - return typ - - where - checkInh (label,typ) = checkIfParType st typ - checkLin (label,typ) = return () ---- checkIfStrType st typ - - -computeLType :: SourceGrammar -> Type -> Check Type -computeLType gr t = do - g0 <- checkGetContext - let g = [(x, Vr x) | (x,_) <- g0] - checkInContext g $ comp t - where - comp ty = case ty of - - App (Q (IC "Predef") (IC "Ints")) _ -> return ty ---- shouldn't be needed - Q (IC "Predef") (IC "Int") -> return ty ---- shouldn't be needed - Q (IC "Predef") (IC "Float") -> return ty ---- shouldn't be needed - Q (IC "Predef") (IC "Error") -> return ty ---- shouldn't be needed - - Q m c | elem c [cPredef,cPredefAbs] -> return ty - Q m c | elem c [zIdent "Int"] -> - return $ linTypeInt - Q m c | elem c [zIdent "Float",zIdent "String"] -> return defLinType ---- - - Q m ident -> checkIn ("module" +++ prt m) $ do - ty' <- checkErr (lookupResDef gr m ident) - if ty' == ty then return ty else comp ty' --- is this necessary to test? - - Vr ident -> checkLookup ident -- never needed to compute! - - App f a -> do - f' <- comp f - a' <- comp a - case f' of - Abs x b -> checkInContext [(x,a')] $ comp b - _ -> return $ App f' a' - - Prod x a b -> do - a' <- comp a - b' <- checkInContext [(x,Vr x)] $ comp b - return $ Prod x a' b' - - Abs x b -> do - b' <- checkInContext [(x,Vr x)] $ comp b - return $ Abs x b' - - ExtR r s -> do - r' <- comp r - s' <- comp s - case (r',s') of - (RecType rs, RecType ss) -> checkErr (plusRecType r' s') >>= comp - _ -> return $ ExtR r' s' - - RecType fs -> do - let fs' = sortBy (\x y -> compare (fst x) (fst y)) fs - liftM RecType $ mapPairsM comp fs' - - _ | ty == typeTok -> return typeStr - _ | isPredefConstant ty -> return ty - - _ -> composOp comp ty - -checkPrintname :: SourceGrammar -> Perh Term -> Check () -checkPrintname st (Yes t) = checkLType st t typeStr >> return () -checkPrintname _ _ = return () - --- | for grammars obtained otherwise than by parsing ---- update!! -checkReservedId :: Ident -> Check () -checkReservedId x = let c = prt x in - if isResWord c - then checkWarn ("Warning: reserved word used as identifier:" +++ c) - else return () - --- to normalize records and record types -labelIndex :: Type -> Label -> Int -labelIndex ty lab = case ty of - RecType ts -> maybe (error ("label index" +++ prt lab)) id $ lookup lab $ labs ts - _ -> error $ "label index" +++ prt ty - where - labs ts = zip (map fst (sortBy (\ x y -> compare (fst x) (fst y)) ts)) [0..] - --- the underlying algorithms - -inferLType :: SourceGrammar -> Term -> Check (Term, Type) -inferLType gr trm = case trm of - - Q m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) - - Q m ident -> checks [ - termWith trm $ checkErr (lookupResType gr m ident) >>= comp - , - checkErr (lookupResDef gr m ident) >>= infer - , -{- - do - over <- getOverload gr Nothing trm - case over of - Just trty -> return trty - _ -> prtFail "not overloaded" trm - , --} - prtFail "cannot infer type of constant" trm - ] - - QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) - - QC m ident -> checks [ - termWith trm $ checkErr (lookupResType gr m ident) >>= comp - , - checkErr (lookupResDef gr m ident) >>= infer - , - prtFail "cannot infer type of canonical constant" trm - ] - - Val ty i -> termWith trm $ return ty - - Vr ident -> termWith trm $ checkLookup ident - - Typed e t -> do - t' <- comp t - check e t' - return (e,t') - - App f a -> do - over <- getOverload gr Nothing trm - case over of - Just trty -> return trty - _ -> do - (f',fty) <- infer f - fty' <- comp fty - case fty' of - Prod z arg val -> do - a' <- justCheck a arg - ty <- if isWildIdent z - then return val - else substituteLType [(z,a')] val - return (App f' a',ty) - _ -> raise ("function type expected for"+++ - prt f +++"instead of" +++ prtType env fty) - - S f x -> do - (f', fty) <- infer f - case fty of - Table arg val -> do - x'<- justCheck x arg - return (S f' x', val) - _ -> prtFail "table lintype expected for the table in" trm - - P t i -> do - (t',ty) <- infer t --- ?? - ty' <- comp ty ------ let tr2 = PI t' i (labelIndex ty' i) - let tr2 = P t' i - termWith tr2 $ checkErr $ case ty' of - RecType ts -> maybeErr ("unknown label" +++ prt i +++ "in" +++ prt ty') $ - lookup i ts - _ -> prtBad ("record type expected for" +++ prt t +++ "instead of") ty' - PI t i _ -> infer $ P t i - - R r -> do - let (ls,fs) = unzip r - fsts <- mapM inferM fs - let ts = [ty | (Just ty,_) <- fsts] - checkCond ("cannot infer type of record"+++ prt trm) (length ts == length fsts) - return $ (R (zip ls fsts), RecType (zip ls ts)) - - T (TTyped arg) pts -> do - (_,val) <- checks $ map (inferCase (Just arg)) pts - check trm (Table arg val) - T (TComp arg) pts -> do - (_,val) <- checks $ map (inferCase (Just arg)) pts - check trm (Table arg val) - T ti pts -> do -- tries to guess: good in oper type inference - let pts' = [pt | pt@(p,_) <- pts, isConstPatt p] - case pts' of - [] -> prtFail "cannot infer table type of" trm ----- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] - _ -> do - (arg,val) <- checks $ map (inferCase Nothing) pts' - check trm (Table arg val) - V arg pts -> do - (_,val) <- checks $ map infer pts - return (trm, Table arg val) - - K s -> do - if elem ' ' s - then checkWarn ("WARNING: space in token \"" ++ s ++ - "\". Lexical analysis may fail.") - else return () - return (trm, typeStr) - - EInt i -> return (trm, typeInt) - - EFloat i -> return (trm, typeFloat) - - Empty -> return (trm, typeStr) - - C s1 s2 -> - check2 (flip justCheck typeStr) C s1 s2 typeStr - - Glue s1 s2 -> - check2 (flip justCheck typeStr) Glue s1 s2 typeStr ---- typeTok - ----- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007 - Strs (Cn (IC "#conflict") : ts) -> do - trace ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) (infer $ head ts) --- checkWarn ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) --- infer $ head ts - - Strs ts -> do - ts' <- mapM (\t -> justCheck t typeStr) ts - return (Strs ts', typeStrs) - - Alts (t,aa) -> do - t' <- justCheck t typeStr - aa' <- flip mapM aa (\ (c,v) -> do - c' <- justCheck c typeStr - v' <- justCheck v typeStrs - return (c',v')) - return (Alts (t',aa'), typeStr) - - RecType r -> do - let (ls,ts) = unzip r - ts' <- mapM (flip justCheck typeType) ts - return (RecType (zip ls ts'), typeType) - - ExtR r s -> do - (r',rT) <- infer r - rT' <- comp rT - (s',sT) <- infer s - sT' <- comp sT - - let trm' = ExtR r' s' - ---- trm' <- checkErr $ plusRecord r' s' - case (rT', sT') of - (RecType rs, RecType ss) -> do - rt <- checkErr $ plusRecType rT' sT' - check trm' rt ---- return (trm', rt) - _ | rT' == typeType && sT' == typeType -> return (trm', typeType) - _ -> prtFail "records or record types expected in" trm - - Sort _ -> - termWith trm $ return typeType - - Prod x a b -> do - a' <- justCheck a typeType - b' <- checkInContext [(x,a')] $ justCheck b typeType - return (Prod x a' b', typeType) - - Table p t -> do - p' <- justCheck p typeType --- check p partype! - t' <- justCheck t typeType - return $ (Table p' t', typeType) - - FV vs -> do - (_,ty) <- checks $ map infer vs ---- checkIfComplexVariantType trm ty - check trm ty - - _ -> prtFail "cannot infer lintype of" trm - - where - env = gr - infer = inferLType env - comp = computeLType env - - check = checkLType env - - isPredef m = elem m [cPredef,cPredefAbs] - - justCheck ty te = check ty te >>= return . fst - - -- for record fields, which may be typed - inferM (mty, t) = do - (t', ty') <- case mty of - Just ty -> check ty t - _ -> infer t - return (Just ty',t') - - inferCase mty (patt,term) = do - arg <- maybe (inferPatt patt) return mty - cont <- pattContext env arg patt - i <- checkUpdates cont - (_,val) <- infer term - checkResets i - return (arg,val) - isConstPatt p = case p of - PC _ ps -> True --- all isConstPatt ps - PP _ _ ps -> True --- all isConstPatt ps - PR ps -> all (isConstPatt . snd) ps - PT _ p -> isConstPatt p - PString _ -> True - PInt _ -> True - PFloat _ -> True - PChar -> True - PSeq p q -> isConstPatt p && isConstPatt q - PAlt p q -> isConstPatt p && isConstPatt q - PRep p -> isConstPatt p - PNeg p -> isConstPatt p - PAs _ p -> isConstPatt p - _ -> False - - inferPatt p = case p of - PP q c ps | q /= cPredef -> checkErr $ lookupResType gr q c >>= valTypeCnc - PAs _ p -> inferPatt p - PNeg p -> inferPatt p - PAlt p q -> checks [inferPatt p, inferPatt q] - PSeq _ _ -> return $ typeStr - PChar -> return $ typeStr - PRep _ -> return $ typeStr - _ -> infer (patt2term p) >>= return . snd - - --- type inference: Nothing, type checking: Just t --- the latter permits matching with value type -getOverload :: SourceGrammar -> Maybe Type -> Term -> Check (Maybe (Term,Type)) -getOverload env@gr mt t = case appForm t of - (f@(Q m c), ts) -> case lookupOverload gr m c of - Ok typs -> do - ttys <- mapM infer ts - v <- matchOverload f typs ttys - return $ Just v - _ -> return Nothing - _ -> return Nothing - where - infer = inferLType env - matchOverload f typs ttys = do - let (tts,tys) = unzip ttys - let vfs = lookupOverloadInstance tys typs - - case [vf | vf@(v,f) <- vfs, matchVal mt v] of - [(val,fun)] -> return (mkApp fun tts, val) - [] -> raise $ "no overload instance of" +++ prt f +++ - "for" +++ unwords (map (prtType env) tys) +++ "among" ++++ - unlines [" " ++ unwords (map (prtType env) ty) | (ty,_) <- typs] ++ - maybe [] (("with value type" +++) . prtType env) mt - - ---- ++++ "DEBUG" +++ unwords (map show tys) +++ ";" - ---- ++++ unlines (map (show . fst) typs) ---- - - vfs' -> case [(v,f) | (v,f) <- vfs', noProd v] of - [(val,fun)] -> do - checkWarn $ "WARNING: overloading of" +++ prt f +++ - "resolved by excluding partial applications:" ++++ - unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)] - return (mkApp fun tts, val) - - _ -> raise $ "ambiguous overloading of" +++ prt f +++ - "for" +++ unwords (map (prtType env) tys) ++++ "with alternatives" ++++ - unlines [prtType env ty | (ty,_) <- vfs'] - - matchVal mt v = elem mt ([Nothing,Just v] ++ unlocked) where - unlocked = case v of - RecType fs -> [Just $ RecType $ filter (not . isLockLabel . fst) fs] - _ -> [] - ---- TODO: accept subtypes - ---- TODO: use a trie - lookupOverloadInstance tys typs = - [(mkFunType rest val, t) | - let lt = length tys, - (ty,(val,t)) <- typs, length ty >= lt, - let (pre,rest) = splitAt lt ty, - pre == tys - ] - - noProd ty = case ty of - Prod _ _ _ -> False - _ -> True - -checkLType :: SourceGrammar -> Term -> Type -> Check (Term, Type) -checkLType env trm typ0 = do - - typ <- comp typ0 - - case trm of - - Abs x c -> do - case typ of - Prod z a b -> do - checkUpdate (x,a) - (c',b') <- if isWildIdent z - then check c b - else do - b' <- checkIn "abs" $ substituteLType [(z,Vr x)] b - check c b' - checkReset - return $ (Abs x c', Prod x a b') - _ -> raise $ "product expected instead of" +++ prtType env typ - - App f a -> do - over <- getOverload env (Just typ) trm - case over of - Just trty -> return trty - _ -> do - (trm',ty') <- infer trm - termWith trm' $ checkEq typ ty' trm' - - Q _ _ -> do - over <- getOverload env (Just typ) trm - case over of - Just trty -> return trty - _ -> do - (trm',ty') <- infer trm - termWith trm' $ checkEq typ ty' trm' - - T _ [] -> - prtFail "found empty table in type" typ - T _ cs -> case typ of - Table arg val -> do - case allParamValues env arg of - Ok vs -> do - let ps0 = map fst cs - ps <- checkErr $ testOvershadow ps0 vs - if null ps - then return () - else checkWarn $ "WARNING: patterns never reached:" +++ - concat (intersperse ", " (map prt ps)) - - _ -> return () -- happens with variable types - cs' <- mapM (checkCase arg val) cs - return (T (TTyped arg) cs', typ) - _ -> raise $ "table type expected for table instead of" +++ prtType env typ - - R r -> case typ of --- why needed? because inference may be too difficult - RecType rr -> do - let (ls,_) = unzip rr -- labels of expected type - fsts <- mapM (checkM r) rr -- check that they are found in the record - return $ (R fsts, typ) -- normalize record - - _ -> prtFail "record type expected in type checking instead of" typ - - ExtR r s -> case typ of - _ | typ == typeType -> do - trm' <- comp trm - case trm' of - RecType _ -> termWith trm $ return typeType - ExtR (Vr _) (RecType _) -> termWith trm $ return typeType - -- ext t = t ** ... - _ -> prtFail "invalid record type extension" trm - RecType rr -> do - (r',ty,s') <- checks [ - do (r',ty) <- infer r - return (r',ty,s) - , - do (s',ty) <- infer s - return (s',ty,r) - ] - case ty of - RecType rr1 -> do - let (rr0,rr2) = recParts rr rr1 - r2 <- justCheck r' rr0 - s2 <- justCheck s' rr2 - return $ (ExtR r2 s2, typ) - _ -> raise ("record type expected in extension of" +++ prt r +++ - "but found" +++ prt ty) - - ExtR ty ex -> do - r' <- justCheck r ty - s' <- justCheck s ex - return $ (ExtR r' s', typ) --- is this all? - - _ -> prtFail "record extension not meaningful for" typ - - FV vs -> do - ttys <- mapM (flip check typ) vs ---- checkIfComplexVariantType trm typ - return (FV (map fst ttys), typ) --- typ' ? - - S tab arg -> checks [ do - (tab',ty) <- infer tab - ty' <- comp ty - case ty' of - Table p t -> do - (arg',val) <- check arg p - checkEq typ t trm - return (S tab' arg', t) - _ -> raise $ "table type expected for applied table instead of" +++ - prtType env ty' - , do - (arg',ty) <- infer arg - ty' <- comp ty - (tab',_) <- check tab (Table ty' typ) - return (S tab' arg', typ) - ] - Let (x,(mty,def)) body -> case mty of - Just ty -> do - (def',ty') <- check def ty - checkUpdate (x,ty') - body' <- justCheck body typ - checkReset - return (Let (x,(Just ty',def')) body', typ) - _ -> do - (def',ty) <- infer def -- tries to infer type of local constant - check (Let (x,(Just ty,def')) body) typ - - _ -> do - (trm',ty') <- infer trm - termWith trm' $ checkEq typ ty' trm' - where - cnc = env - infer = inferLType env - comp = computeLType env - - check = checkLType env - - justCheck ty te = check ty te >>= return . fst - - checkEq = checkEqLType env - - recParts rr t = (RecType rr1,RecType rr2) where - (rr1,rr2) = partition (flip elem (map fst t) . fst) rr - - checkM rms (l,ty) = case lookup l rms of - Just (Just ty0,t) -> do - checkEq ty ty0 t - (t',ty') <- check t ty - return (l,(Just ty',t')) - Just (_,t) -> do - (t',ty') <- check t ty - return (l,(Just ty',t')) - _ -> prtFail "cannot find value for label" l - - checkCase arg val (p,t) = do - cont <- pattContext env arg p - i <- checkUpdates cont - t' <- justCheck t val - checkResets i - return (p,t') - -pattContext :: LTEnv -> Type -> Patt -> Check Context -pattContext env typ p = case p of - PV x | not (isWildIdent x) -> return [(x,typ)] - PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006 - t <- checkErr $ lookupResType cnc q c - (cont,v) <- checkErr $ typeFormCnc t - checkCond ("wrong number of arguments for constructor in" +++ prt p) - (length cont == length ps) - checkEqLType env typ v (patt2term p) - mapM (uncurry (pattContext env)) (zip (map snd cont) ps) >>= return . concat - PR r -> do - typ' <- computeLType env typ - case typ' of - RecType t -> do - let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]] - ----- checkWarn $ prt p ++++ show pts ----- debug - mapM (uncurry (pattContext env)) pts >>= return . concat - _ -> prtFail "record type expected for pattern instead of" typ' - PT t p' -> do - checkEqLType env typ t (patt2term p') - pattContext env typ p' - - PAs x p -> do - g <- pattContext env typ p - return $ (x,typ):g - - PAlt p' q -> do - g1 <- pattContext env typ p' - g2 <- pattContext env typ q - let pts = [pt | pt <- g1, notElem pt g2] ++ [pt | pt <- g2, notElem pt g1] - checkCond - ("incompatible bindings of" +++ - unwords (nub (map (prt . fst) pts))+++ - "in pattern alterantives" +++ prt p) (null pts) - return g1 -- must be g1 == g2 - PSeq p q -> do - g1 <- pattContext env typ p - g2 <- pattContext env typ q - return $ g1 ++ g2 - PRep p' -> noBind typeStr p' - PNeg p' -> noBind typ p' - - _ -> return [] ---- check types! - where - cnc = env - noBind typ p' = do - co <- pattContext env typ p' - if not (null co) - then checkWarn ("no variable bound inside pattern" +++ prt p) - >> return [] - else return [] - --- auxiliaries - -type LTEnv = SourceGrammar - -termWith :: Term -> Check Type -> Check (Term, Type) -termWith t ct = do - ty <- ct - return (t,ty) - --- | light-weight substitution for dep. types -substituteLType :: Context -> Type -> Check Type -substituteLType g t = case t of - Vr x -> return $ maybe t id $ lookup x g - _ -> composOp (substituteLType g) t - --- | compositional check\/infer of binary operations -check2 :: (Term -> Check Term) -> (Term -> Term -> Term) -> - Term -> Term -> Type -> Check (Term,Type) -check2 chk con a b t = do - a' <- chk a - b' <- chk b - return (con a' b', t) - -checkEqLType :: LTEnv -> Type -> Type -> Term -> Check Type -checkEqLType env t u trm = do - (b,t',u',s) <- checkIfEqLType env t u trm - case b of - True -> return t' - False -> raise $ s +++ "type of" +++ prt trm +++ - ": expected:" +++ prtType env t ++++ - "inferred:" +++ prtType env u - -checkIfEqLType :: LTEnv -> Type -> Type -> Term -> Check (Bool,Type,Type,String) -checkIfEqLType env t u trm = do - t' <- comp t - u' <- comp u - case t' == u' || alpha [] t' u' of - True -> return (True,t',u',[]) - -- forgive missing lock fields by only generating a warning. - --- better: use a flag to forgive? (AR 31/1/2006) - _ -> case missingLock [] t' u' of - Ok lo -> do - checkWarn $ "WARNING: missing lock field" +++ unwords (map prt lo) - return (True,t',u',[]) - Bad s -> return (False,t',u',s) - - where - - -- t is a subtype of u - --- quick hack version of TC.eqVal - alpha g t u = case (t,u) of - - -- error (the empty type!) is subtype of any other type - (_,Q (IC "Predef") (IC "Error")) -> True - - -- contravariance - (Prod x a b, Prod y c d) -> alpha g c a && alpha ((x,y):g) b d - - -- record subtyping - (RecType rs, RecType ts) -> all (\ (l,a) -> - any (\ (k,b) -> alpha g a b && l == k) ts) rs - (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s' - (ExtR r s, t) -> alpha g r t || alpha g s t - - -- the following say that Ints n is a subset of Int and of Ints m >= n - (App (Q (IC "Predef") (IC "Ints")) (EInt n), - App (Q (IC "Predef") (IC "Ints")) (EInt m)) -> m >= n - (App (Q (IC "Predef") (IC "Ints")) (EInt n), - Q (IC "Predef") (IC "Int")) -> True ---- check size! - - (Q (IC "Predef") (IC "Int"), ---- why this ???? AR 11/12/2005 - App (Q (IC "Predef") (IC "Ints")) (EInt n)) -> True - - ---- this should be made in Rename - (Q m a, Q n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - || m == n --- for Predef - (QC m a, QC n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - (QC m a, Q n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - (Q m a, QC n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - - (Table a b, Table c d) -> alpha g a c && alpha g b d - (Vr x, Vr y) -> x == y || elem (x,y) g || elem (y,x) g - _ -> t == u - --- the following should be one-way coercions only. AR 4/1/2001 - || elem t sTypes && elem u sTypes - || (t == typeType && u == typePType) - || (u == typeType && t == typePType) - - missingLock g t u = case (t,u) of - (RecType rs, RecType ts) -> - let - ls = [l | (l,a) <- rs, - not (any (\ (k,b) -> alpha g a b && l == k) ts)] - (locks,others) = partition isLockLabel ls - in case others of - _:_ -> Bad $ "missing record fields" +++ unwords (map prt others) - _ -> return locks - -- contravariance - (Prod x a b, Prod y c d) -> do - ls1 <- missingLock g c a - ls2 <- missingLock g b d - return $ ls1 ++ ls2 - - _ -> Bad "" - - sTypes = [typeStr, typeTok, typeString] - comp = computeLType env - --- printing a type with a lock field lock_C as C -prtType :: LTEnv -> Type -> String -prtType env ty = case ty of - RecType fs -> case filter isLockLabel $ map fst fs of - [lock] -> (drop 5 $ prt lock) --- ++++ "Full form" +++ prt ty - _ -> prtt ty - Prod x a b -> prtType env a +++ "->" +++ prtType env b - _ -> prtt ty - where - prtt t = prt t - ---- use computeLType gr to check if really equal to the cat with lock - - --- | linearization types and defaults -linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type) -linTypeOfType cnc m typ = do - (cont,cat) <- checkErr $ typeSkeleton typ - val <- lookLin cat - args <- mapM mkLinArg (zip [0..] cont) - return (args, val) - where - mkLinArg (i,(n,mc@(m,cat))) = do - val <- lookLin mc - let vars = mkRecType varLabel $ replicate n typeStr - symb = argIdent n cat i - rec <- checkErr $ errIn ("extending" +++ prt vars +++ "with" +++ prt val) $ - plusRecType vars val - return (symb,rec) - lookLin (_,c) = checks [ --- rather: update with defLinType ? - checkErr (lookupLincat cnc m c) >>= computeLType cnc - ,return defLinType - ] - --- | dependency check, detecting circularities and returning topo-sorted list - -allOperDependencies :: Ident -> BinTree Ident Info -> [(Ident,[Ident])] -allOperDependencies m = allDependencies (==m) - -allDependencies :: (Ident -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])] -allDependencies ism b = - [(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b] - where - opersIn t = case t of - Q n c | ism n -> [c] - QC n c | ism n -> [c] - _ -> collectOp opersIn t - opty (Yes ty) = opersIn ty - opty _ = [] - pts i = case i of - ResOper pty pt -> [pty,pt] - ResParam (Yes (ps,_)) -> [Yes t | (_,cont) <- ps, (_,t) <- cont] - CncCat pty _ _ -> [pty] - CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type)) - AbsFun pty ptr -> [pty] --- ptr is def, which can be mutual - AbsCat (Yes co) _ -> [Yes ty | (_,ty) <- co] - _ -> [] - -topoSortOpers :: [(Ident,[Ident])] -> Err [Ident] -topoSortOpers st = do - let eops = topoTest st - either - return - (\ops -> Bad ("circular definitions:" +++ unwords (map prt (head ops)))) - eops diff --git a/src-3.0/GF/Compile/Compile.hs b/src-3.0/GF/Compile/Compile.hs deleted file mode 100644 index 422df0fd5..000000000 --- a/src-3.0/GF/Compile/Compile.hs +++ /dev/null @@ -1,401 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Compile --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/05 20:02:19 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.45 $ --- --- The top-level compilation chain from source file to gfc\/gfr. ------------------------------------------------------------------------------ - -module GF.Compile.Compile (compileModule, compileEnvShSt, compileOne, - CompileEnv, TimedCompileEnv,gfGrammarPathVar,pathListOpts, - getGFEFiles) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Option -import GF.Infra.CompactPrint -import GF.Grammar.PrGrammar -import GF.Compile.Update -import GF.Grammar.Lookup -import GF.Infra.Modules -import GF.Infra.ReadFiles -import GF.Compile.ShellState -import GF.Compile.MkResource ----- import MkUnion - --- the main compiler passes -import GF.Compile.GetGrammar -import GF.Compile.Extend -import GF.Compile.Rebuild -import GF.Compile.Rename -import GF.Grammar.Refresh -import GF.Compile.CheckGrammar -import GF.Compile.Optimize -import GF.Compile.Evaluate -import GF.Compile.GrammarToCanon ---import GF.Devel.GrammarToGFCC ----- -import GF.Devel.OptimizeGF (subexpModule,unsubexpModule) -import GF.Canon.Share -import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule) -import GF.UseGrammar.Linear (unoptimizeCanonMod) ---- - -import qualified GF.Canon.CanonToGrammar as CG - -import qualified GF.Canon.GFC as GFC -import qualified GF.Canon.MkGFC as MkGFC -import GF.Canon.GetGFC - -import GF.Data.Operations -import GF.Infra.UseIO -import GF.Text.UTF8 ---- -import GF.System.Arch - -import Control.Monad -import System.Directory -import System.FilePath - --- | in batch mode: write code in a file -batchCompile f = liftM fst $ compileModule defOpts emptyShellState f - where - defOpts = options [emitCode] -batchCompileOpt f = liftM fst $ compileModule defOpts emptyShellState f - where - defOpts = options [emitCode, optimizeCanon] - -batchCompileOld f = compileOld defOpts f - where - defOpts = options [emitCode] - --- | compile with one module as starting point --- command-line options override options (marked by --#) in the file --- As for path: if it is read from file, the file path is prepended to each name. --- If from command line, it is used as it is. -compileModule :: Options -> ShellState -> FilePath -> IOE TimedCompileEnv ----- IOE (GFC.CanonGrammar, (SourceGrammar,[(String,(FilePath,ModTime))])) - -compileModule opts st0 file | - oElem showOld opts || - elem suff [".cf",".ebnf",".gfm"] = do - let putp = putPointE opts - let putpp = putPointEsil opts - let path = [] ---- - grammar1 <- case suff of - ".cf" -> putp ("- parsing" +++ suff +++ file) $ getCFGrammar opts file - ".ebnf" -> putp ("- parsing" +++ suff +++ file) $ getEBNFGrammar opts file - ".gfm" -> putp ("- parsing" +++ suff +++ file) $ getSourceGrammar opts file - _ -> putp ("- parsing old gf" +++ file) $ getOldGrammar opts file - let mods = modules grammar1 - let env = compileEnvShSt st0 [] - foldM (comp putpp path) env mods - where - suff = takeExtensions file - comp putpp path env sm0 = do - (k',sm,eenv') <- makeSourceModule opts (fst env) sm0 - cm <- putpp " generating code... " $ generateModuleCode opts path sm - ft <- getReadTimes file --- - extendCompileEnvInt env (k',sm,cm) eenv' ft - -compileModule opts1 st0 file = do - opts0 <- ioeIO $ getOptionsFromFile file - let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList - let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList - let opts = addOptions opts1 opts0 - let fpath = dropFileName file - ps0 <- ioeIO $ pathListOpts opts fpath - - let ps1 = if (useFileOpt && not useLineOpt) - then (ps0 ++ map (combine fpath) ps0) - else ps0 - ps <- ioeIO $ extendPathEnv ps1 - let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ())) - ioeIOIf $ putStrLn $ "module search path:" +++ show ps ---- - let st = st0 --- if useFileOpt then emptyShellState else st0 - let rfs = [(m,t) | (m,(_,t)) <- readFiles st] - let file' = if useFileOpt then takeFileName file else file -- to find file itself - files <- getAllFiles opts ps rfs file' - ioeIOIf $ putStrLn $ "files to read:" +++ show files ---- - let names = map justModuleName files - ioeIOIf $ putStrLn $ "modules to include:" +++ show names ---- - let env0 = compileEnvShSt st names - (e,mm) <- foldIOE (compileOne opts) env0 files - maybe (return ()) putStrLnE mm - return e - -getReadTimes file = do - t <- ioeIO getNowTime - let m = justModuleName file - return $ (m,(file,t)) : [(resModName m,(file,t)) | not (isGFC file)] - -compileEnvShSt :: ShellState -> [ModName] -> TimedCompileEnv -compileEnvShSt st fs = ((0,sgr,cgr,eenv),fts) where - cgr = MGrammar [m | m@(i,_) <- modules (canModules st), notInc i] - sgr = MGrammar [m | m@(i,_) <- modules (srcModules st), notIns i] - notInc i = notElem (prt i) $ map dropExtension fs - notIns i = notElem (prt i) $ map dropExtension fs - fts = readFiles st - eenv = evalEnv st - -pathListOpts :: Options -> FileName -> IO [InitPath] -pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ getOptVal opts pathList - -reverseModules (MGrammar ms) = MGrammar $ reverse ms - -keepResModules :: Options -> SourceGrammar -> SourceGrammar -keepResModules opts gr = - if oElem retainOpers opts - then MGrammar $ reverse [(i,mi) | (i,mi@(ModMod m)) <- modules gr, isModRes m] - else emptyMGrammar - - --- | the environment -type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar,EEnv) - -emptyCompileEnv :: TimedCompileEnv -emptyCompileEnv = ((0,emptyMGrammar,emptyMGrammar,emptyEEnv),[]) - -extendCompileEnvInt ((_,MGrammar ss, MGrammar cs,_),fts) (k,sm,cm) eenv ft = - return ((k,MGrammar (sm:ss), MGrammar (cm:cs),eenv),ft++fts) --- reverse later - -extendCompileEnv e@((k,_,_,_),_) (sm,cm) = extendCompileEnvInt e (k,sm,cm) - -extendCompileEnvCanon ((k,s,c,e),fts) cgr eenv ft = - return ((k,s, MGrammar (modules cgr ++ modules c),eenv),ft++fts) - -type TimedCompileEnv = (CompileEnv,[(String,(FilePath,ModTime))]) - -compileOne :: Options -> TimedCompileEnv -> FullPath -> IOE TimedCompileEnv -compileOne opts env@((_,srcgr,cancgr0,eenv),_) file = do - - let putp = putPointE opts - let putpp = putPointEsil opts - let putpOpt v m act - | oElem beVerbose opts = putp v act - | oElem beSilent opts = putpp v act - | otherwise = ioeIO (putStrFlush m) >> act - - let gf = takeExtensions file - let path = dropFileName file - let name = dropExtension file - let mos = modules srcgr - - case gf of - -- for multilingual canonical gf, just read the file and update environment - ".gfcm" -> do - cgr <- putp ("+ reading" +++ file) $ getCanonGrammar file - ft <- getReadTimes file - extendCompileEnvCanon env cgr eenv ft - - -- for canonical gf, read the file and update environment, also source env - ".gfc" -> do - cm <- putp ("+ reading" +++ file) $ getCanonModule file - let cancgr = updateMGrammar (MGrammar [cm]) cancgr0 - sm <- ioeErr $ CG.canon2sourceModule $ unoptimizeCanonMod cancgr $ unSubelimModule cm - ft <- getReadTimes file - extendCompileEnv env (sm, cm) eenv ft - - -- for compiled resource, parse and organize, then update environment - ".gfr" -> do - sm0 <- putp ("| reading" +++ file) $ getSourceModule opts file - let sm1 = unsubexpModule sm0 - sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm1 ----- experiment with not optimizing gfr ----- sm:_ <- putp " optimizing " $ ioeErr $ evalModule mos sm1 - let gfc = gfcFile name - cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc - ft <- getReadTimes file - extendCompileEnv env (sm,cm) eenv ft - - -- for gf source, do full compilation - - _ -> do - - --- hack fix to a bug in ReadFiles with reused concrete - - let modu = dropExtension file - b1 <- ioeIO $ doesFileExist file - b2 <- ioeIO $ doesFileExist $ gfrFile modu - if not b1 - then if b2 - then compileOne opts env $ gfrFile $ modu - else compileOne opts env $ gfcFile $ modu - else do - - sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ - getSourceModule opts file - (k',sm,eenv') <- makeSourceModule opts (fst env) sm0 - cm <- putpp " generating code... " $ generateModuleCode opts path sm - ft <- getReadTimes file - - sm':_ <- case snd sm of ----- ModMod n | isModRes n -> putp " optimizing " $ ioeErr $ evalModule mos sm - _ -> return [sm] - - extendCompileEnvInt env (k',sm',cm) eenv' ft - --- | dispatch reused resource at early stage -makeSourceModule :: Options -> CompileEnv -> - SourceModule -> IOE (Int,SourceModule,EEnv) -makeSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = case mi of - - ModMod m -> case mtype m of - MTReuse c -> do - sm <- ioeErr $ makeReuse gr i (extend m) c - let mo2 = (i, ModMod sm) - mos = modules gr - --- putp " type checking reused" $ ioeErr $ showCheckModule mos mo2 - return $ (k,mo2,eenv) -{- ---- obsolete - MTUnion ty imps -> do - mo' <- ioeErr $ makeUnion gr i ty imps - compileSourceModule opts env mo' --} - - _ -> compileSourceModule opts env mo - _ -> compileSourceModule opts env mo - where - putp = putPointE opts - -compileSourceModule :: Options -> CompileEnv -> - SourceModule -> IOE (Int,SourceModule,EEnv) -compileSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = do - - let putp = putPointE opts - putpp = putPointEsil opts - mos = modules gr - - if (oElem showOld opts && oElem emitCode opts) - then do - let (file,out) = (gfFile (prt i), prGrammar (MGrammar [mo])) - putp (" wrote file" +++ file) $ ioeIO $ writeFile file out - else return () - - mo1 <- ioeErr $ rebuildModule mos mo - - mo1b <- ioeErr $ extendModule mos mo1 - - case mo1b of - (_,ModMod n) | not (isCompleteModule n) -> do - return (k,mo1b,eenv) -- refresh would fail, since not renamed - _ -> do - mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b - - (mo3:_,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule mos mo2 - if null warnings then return () else putp warnings $ return () - - (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 - - (mo4,eenv') <- - ---- if oElem "check_only" opts - putpp " optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r - return (k',mo4,eenv') - where - ---- prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug - prDebug mo = ioeIO $ print $ length $ lines $ prGrammar $ MGrammar [mo] - -generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule -generateModuleCode opts path minfo@(name,info) = do - ---- DEPREC ---- if oElem (iOpt "gfcc") opts ---- then ioeIO $ putStrLn $ prGrammar2gfcc minfo ---- else return () - - let pname = path </> prt name - minfo0 <- ioeErr $ redModInfo minfo - let oopts = addOptions opts (iOpts (flagsModule minfo)) - optims = maybe "all_subs" id $ getOptVal oopts useOptimizer - optim = takeWhile (/='_') optims - subs = drop 1 (dropWhile (/='_') optims) == "subs" - minfo1 <- return $ - case optim of - "parametrize" -> shareModule paramOpt minfo0 -- parametrization and sharing - "values" -> shareModule valOpt minfo0 -- tables as courses-of-values - "share" -> shareModule shareOpt minfo0 -- sharing of branches - "all" -> shareModule allOpt minfo0 -- first parametrize then values - "none" -> minfo0 -- no optimization - _ -> shareModule shareOpt minfo0 -- sharing; default - - -- do common subexpression elimination if required by flag "subs" - minfo' <- - if subs - then ioeErr $ elimSubtermsMod minfo1 - else return minfo1 - - -- for resource, also emit gfr. - --- Also for incomplete, to create timestamped gfc/gfr files - case info of - ModMod m | emitsGFR m && emit && nomulti -> do - let rminfo = if isCompilable info - then subexpModule minfo - else (name, ModMod emptyModule) - let (file,out) = (gfrFile pname, prGrammar (MGrammar [rminfo])) - putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ compactPrint out - _ -> return () - let encode = case getOptVal opts uniCoding of - Just "utf8" -> encodeUTF8 - _ -> id - (file,out) <- do - code <- return $ MkGFC.prCanonModInfo minfo' - return (gfcFile pname, encode code) - if emit && nomulti ---- && isCompilable info - then putp (" wrote file" +++ file) $ ioeIO $ writeFile file out - else putpp ("no need to save module" +++ prt name) $ return () - return minfo' - where - putp = putPointE opts - putpp = putPointEsil opts - - emitsGFR m = isModRes m ---- && isCompilable info - ---- isModRes m || (isModCnc m && mstatus m == MSIncomplete) - isCompilable mi = case mi of - ModMod m -> not $ isModCnc m && mstatus m == MSIncomplete - _ -> True - nomulti = not $ oElem makeMulti opts - emit = oElem emitCode opts && not (oElem notEmitCode opts) - --- for old GF: sort into modules, write files, compile as usual - -compileOld :: Options -> FilePath -> IOE GFC.CanonGrammar -compileOld opts file = do - let putp = putPointE opts - grammar1 <- putp ("- parsing old gf" +++ file) $ getOldGrammar opts file - files <- mapM writeNewGF $ modules grammar1 - ((_,_,grammar,_),_) <- foldM (compileOne opts) emptyCompileEnv files - return grammar - -writeNewGF :: SourceModule -> IOE FilePath -writeNewGF m@(i,_) = do - let file = gfFile $ prt i - ioeIO $ writeFile file $ prGrammar (MGrammar [m]) - ioeIO $ putStrLn $ "wrote file" +++ file - return file - ---- this function duplicates a lot of code from compileModule. ---- It does not really belong here either. --- It selects those .gfe files that a grammar depends on and that --- are younger than corresponding gf - -getGFEFiles :: Options -> FilePath -> IO [FilePath] -getGFEFiles opts1 file = useIOE [] $ do - opts0 <- ioeIO $ getOptionsFromFile file - let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList - let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList - let opts = addOptions opts1 opts0 - let fpath = dropFileName file - ps0 <- ioeIO $ pathListOpts opts fpath - - let ps1 = if (useFileOpt && not useLineOpt) - then (map (combine fpath) ps0) - else ps0 - ps <- ioeIO $ extendPathEnv ps1 - let file' = if useFileOpt then takeFileName file else file -- to find file itself - files <- getAllFiles opts ps [] file' - efiles <- ioeIO $ filterM doesFileExist [replaceExtension f "gfe" | f <- files] - es <- ioeIO $ mapM (uncurry selectLater) [(f, init f) | f <- efiles] -- init gfe == gf - return $ filter ((=='e') . last) es diff --git a/src-3.0/GF/Compile/Evaluate.hs b/src-3.0/GF/Compile/Evaluate.hs deleted file mode 100644 index a574fef40..000000000 --- a/src-3.0/GF/Compile/Evaluate.hs +++ /dev/null @@ -1,477 +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, EEnv, emptyEEnv) 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 - (FTC c, _:_) -> FTC $ foldl App c ts - _ -> ft - -apps :: Term -> (Term,[Term]) -apps t = case t of - App f a -> (f',xs ++ [a]) where (f',xs) = apps f - _ -> (t,[]) - -appEvalConcrete gr bt env = appSTM (evalConcrete gr bt) env - -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 >>= recomp subst - return $ mkAbs vars trm3 - - ---- temporary hack to ascertain full evaluation, because of bug in comp - recomp g t = if notReady t then comp g t else return t - notReady = not . null . redexes - redexes t = case t of - Q _ _ -> return [()] - _ -> collectOp redexes t - - 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") _ -> return t ----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@(QC p c),xs) -> do - xs' <- mapM (comp g) xs - case lookupValueIndex gr ty t of - Ok v -> return v - _ -> return t --} - (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) - ExtR (R a) b -> case lookup l a of ----comp g (P (R b) l) of - Just (_,v) -> comp g v - _ -> comp g (P b 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' - - (_, FV ss) -> liftM FV $ mapM (comp g) [ExtR t u | u <- ss] - - _ -> 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-3.0/GF/Compile/Flatten.hs b/src-3.0/GF/Compile/Flatten.hs deleted file mode 100644 index 1168ca6da..000000000 --- a/src-3.0/GF/Compile/Flatten.hs +++ /dev/null @@ -1,92 +0,0 @@ -module Flatten where - -import Data.List --- import GF.Data.Operations - --- (AR 15/3/2006) --- --- A method for flattening grammars: create many flat rules instead of --- a few deep ones. This is generally better for parsins. --- The rules are obtained as follows: --- 1. write a config file tellinq which constants are variables: format 'c : C' --- 2. generate a list of trees with their types: format 't : T' --- 3. for each such tree, form a fun rule 'fun fui : X -> Y -> T' and a lin --- rule 'lin fui x y = t' where x:X,y:Y is the list of variables in t, as --- found in the config file. --- 4. You can go on and produce def or transfer rules similar to the lin rules --- except for the keyword. --- --- So far this module is used outside gf. You can e.g. generate a list of --- trees by 'gt', write it in a file, and then in ghci call --- flattenGrammar <Config> <Trees> <OutFile> - -type Ident = String --- -type Term = String --- -type Rule = String --- - -type Config = [(Ident,Ident)] - -flattenGrammar :: FilePath -> FilePath -> FilePath -> IO () -flattenGrammar conff tf out = do - conf <- readFile conff >>= return . lines - ts <- readFile tf >>= return . lines - writeFile out $ mkFlatten conf ts - -mkFlatten :: [String] -> [String] -> String -mkFlatten conff = unlines . concatMap getOne . zip [1..] where - getOne (k,t) = let (x,y) = mkRules conf ("fu" ++ show k) t in [x,y] - conf = getConfig conff - -mkRules :: Config -> Ident -> Term -> (Rule,Rule) -mkRules conf f t = (fun f ty, lin f (takeWhile (/=':') t)) where - args = mkArgs conf ts - ty = concat [a ++ " -> " | a <- map snd args] ++ val - (ts,val) = let tt = lexTerm t in (init tt,last tt) ---- f = identV t - fun c a = unwords [" fun", c, ":",a,";"] - lin c a = unwords $ [" lin", c] ++ map fst args ++ ["=",a,";"] - -mkArgs :: Config -> [Ident] -> [(Ident,Ident)] -mkArgs conf ids = [(x,ty) | x <- ids, Just ty <- [lookup x conf]] - -mkIdent :: Term -> Ident -mkIdent = map mkChar where - mkChar c = case c of - '(' -> '6' - ')' -> '9' - ' ' -> '_' - _ -> c - --- to get just the identifiers -lexTerm :: String -> [String] -lexTerm ss = case lex ss of - [([c],ws)] | isSpec c -> lexTerm ws - [(w@(_:_),ws)] -> w : lexTerm ws - _ -> [] - where - isSpec = flip elem "();:" - - -getConfig :: [String] -> Config -getConfig = map getOne . filter (not . null) where - getOne line = case lexTerm line of - v:c:_ -> (v,c) - -ex = putStrLn fs where - fs = - mkFlatten - ["man_N : N", - "sleep_V : V" - ] - ["PredVP (DefSg man_N) (UseV sleep_V) : Cl", - "PredVP (DefPl man_N) (UseV sleep_V) : Cl" - ] - -{- --- result of ex - - fun fu1 : N -> V -> Cl ; - lin fu1 man_N sleep_V = PredVP (DefSg man_N) (UseV sleep_V) ; - fun fu2 : N -> V -> Cl ; - lin fu2 man_N sleep_V = PredVP (DefPl man_N) (UseV sleep_V) ; --} diff --git a/src-3.0/GF/Compile/GetGrammar.hs b/src-3.0/GF/Compile/GetGrammar.hs deleted file mode 100644 index 294edbf9a..000000000 --- a/src-3.0/GF/Compile/GetGrammar.hs +++ /dev/null @@ -1,146 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GetGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/15 17:56:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.16 $ --- --- this module builds the internal GF grammar that is sent to the type checker ------------------------------------------------------------------------------ - -module GF.Compile.GetGrammar ( - getSourceModule, getSourceGrammar, - getOldGrammar, getCFGrammar, getEBNFGrammar - ) where - -import GF.Data.Operations -import qualified GF.Source.ErrM as E - -import GF.Infra.UseIO -import GF.Grammar.Grammar -import GF.Infra.Modules -import GF.Grammar.PrGrammar -import qualified GF.Source.AbsGF as A -import GF.Source.SourceToGrammar ----- import Macros ----- import Rename -import GF.Text.UTF8 ---- -import GF.Infra.Option ---- import Custom -import GF.Source.ParGF -import qualified GF.Source.LexGF as L - -import GF.CF.CF (rules2CF) -import GF.CF.PPrCF -import GF.CF.CFtoGrammar -import GF.CF.EBNF - -import GF.Infra.ReadFiles ---- - -import Data.Char (toUpper) -import Data.List (nub) -import qualified Data.ByteString.Char8 as BS -import Control.Monad (foldM) -import System (system) -import System.FilePath - -getSourceModule :: Options -> FilePath -> IOE SourceModule -getSourceModule opts file0 = do - file <- case getOptVal opts usePreprocessor of - Just p -> do - let tmp = "_gf_preproc.tmp" - cmd = p +++ file0 ++ ">" ++ tmp - ioeIO $ system cmd - -- ioeIO $ putStrLn $ "preproc" +++ cmd - return tmp - _ -> return file0 - string0 <- readFileIOE file - let string = case getOptVal opts uniCoding of - Just "utf8" -> decodeUTF8 string0 - _ -> string0 - let tokens = myLexer (BS.pack string) - mo1 <- ioeErr $ pModDef tokens - ioeErr $ transModDef mo1 - -getSourceGrammar :: Options -> FilePath -> IOE SourceGrammar -getSourceGrammar opts file = do - string <- readFileIOE file - let tokens = myLexer (BS.pack string) - gr1 <- ioeErr $ pGrammar tokens - ioeErr $ transGrammar gr1 - - --- for old GF format with includes - -getOldGrammar :: Options -> FilePath -> IOE SourceGrammar -getOldGrammar opts file = do - defs <- parseOldGrammarFiles file - let g = A.OldGr A.NoIncl defs - let name = takeFileName file - ioeErr $ transOldGrammar opts name g - -parseOldGrammarFiles :: FilePath -> IOE [A.TopDef] -parseOldGrammarFiles file = do - putStrLnE $ "reading grammar of old format" +++ file - (_, g) <- getImports "" ([],[]) file - return g -- now we can throw away includes - where - getImports oldInitPath (oldImps, oldG) f = do - (path,s) <- readFileLibraryIOE oldInitPath f - if not (elem path oldImps) - then do - (imps,g) <- parseOldGrammar path - foldM (getImports (initFilePath path)) (path : oldImps, g ++ oldG) imps - else - return (oldImps, oldG) - -parseOldGrammar :: FilePath -> IOE ([FilePath],[A.TopDef]) -parseOldGrammar file = do - putStrLnE $ "reading old file" +++ file - s <- ioeIO $ readFileIf file - A.OldGr incl topdefs <- ioeErr $ pOldGrammar $ oldLexer $ fixNewlines s - includes <- ioeErr $ transInclude incl - return (includes, topdefs) - ----- - --- | To resolve the new reserved words: --- change them by turning the final letter to upper case. ---- There is a risk of clash. -oldLexer :: String -> [L.Token] -oldLexer = map change . L.tokens . BS.pack where - change t = case t of - (L.PT p (L.TS s)) | elem s newReservedWords -> - (L.PT p (L.TV (init s ++ [toUpper (last s)]))) - _ -> t - -getCFGrammar :: Options -> FilePath -> IOE SourceGrammar -getCFGrammar opts file = do - let mo = takeWhile (/='.') file - s <- ioeIO $ readFileIf file - let files = case words (concat (take 1 (lines s))) of - "--":"include":fs -> fs - _ -> [] - ss <- ioeIO $ mapM readFileIf files - cfs <- ioeErr $ mapM (pCF mo) $ s:ss - defs <- return $ cf2grammar $ rules2CF $ concat cfs - let g = A.OldGr A.NoIncl defs ---- let ma = justModuleName file ---- let mc = 'C':ma --- ---- let opts' = addOptions (options [useAbsName ma, useCncName mc]) opts - ioeErr $ transOldGrammar opts file g - -getEBNFGrammar :: Options -> FilePath -> IOE SourceGrammar -getEBNFGrammar opts file = do - let mo = takeWhile (/='.') file - s <- ioeIO $ readFileIf file - defs <- ioeErr $ pEBNFasGrammar s - let g = A.OldGr A.NoIncl defs ---- let ma = justModuleName file ---- let mc = 'C':ma --- ---- let opts' = addOptions (options [useAbsName ma, useCncName mc]) opts - ioeErr $ transOldGrammar opts file g diff --git a/src-3.0/GF/Compile/GrammarToCanon.hs b/src-3.0/GF/Compile/GrammarToCanon.hs deleted file mode 100644 index 09c0d3d95..000000000 --- a/src-3.0/GF/Compile/GrammarToCanon.hs +++ /dev/null @@ -1,293 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GrammarToCanon --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:33 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.23 $ --- --- Code generator from optimized GF source code to GFC. ------------------------------------------------------------------------------ - -module GF.Compile.GrammarToCanon (showGFC, - redModInfo, redQIdent - ) where - -import GF.Data.Operations -import GF.Data.Zipper -import GF.Infra.Option -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Grammar.PrGrammar -import GF.Infra.Modules -import GF.Grammar.Macros -import qualified GF.Canon.AbsGFC as G -import qualified GF.Canon.GFC as C -import GF.Canon.MkGFC ----- import Alias -import qualified GF.Canon.PrintGFC as P - -import Control.Monad -import Data.List (nub,sortBy) - --- compilation of optimized grammars to canonical GF. AR 5/10/2001 -- 12/5/2003 - --- | This is the top-level function printing a gfc file -showGFC :: SourceGrammar -> String -showGFC = err id id . liftM (P.printTree . grammar2canon) . redGrammar - --- | any grammar, first trying without dependent types --- abstract syntax without dependent types -redGrammar :: SourceGrammar -> Err C.CanonGrammar -redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo $ filter active gr where - active (_,m) = case typeOfModule m of - MTInterface -> False - _ -> True - -redModInfo :: (Ident, SourceModInfo) -> Err (Ident, C.CanonModInfo) -redModInfo (c,info) = do - c' <- redIdent c - info' <- case info of - ModMod m -> do - let isIncompl = not $ isCompleteModule m - (e,os) <- if isIncompl then return ([],[]) else redExtOpen m ---- - flags <- mapM redFlag $ flags m - (a,mt0) <- case mtype m of - MTConcrete a -> do - a' <- redIdent a - return (a', MTConcrete a') - MTAbstract -> return (c',MTAbstract) --- c' not needed - MTResource -> return (c',MTResource) --- c' not needed - MTInterface -> return (c',MTResource) ---- not needed - MTInstance _ -> return (c',MTResource) --- c' not needed - MTTransfer x y -> return (c',MTTransfer (om x) (om y)) --- c' not needed - - --- this generates empty GFC reosurce for interface and incomplete - let js = if isIncompl then emptyBinTree else jments m - mt = mt0 ---- if isIncompl then MTResource else mt0 - - defss <- mapM (redInfo a) $ tree2list $ js - let defs0 = concat defss - let lgh = length defs0 - defs <- return $ sorted2tree $ defs0 -- sorted, but reduced - let flags1 = if isIncompl then C.flagIncomplete : flags else flags - let flags' = G.Flg (identC "modulesize") (identC ("n"++show lgh)) : flags1 - return $ ModMod $ Module mt MSComplete flags' e os defs - return (c',info') - where - redExtOpen m = do - e' <- case extends m of - es -> mapM (liftM inheritAll . redIdent) es - os' <- mapM (\o -> case o of - OQualif q _ i -> liftM (OSimple q) (redIdent i) - _ -> prtBad "cannot translate unqualified open in" c) $ opens m - return (e',nub os') - om = oSimple . openedModule --- normalizing away qualif - -redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)] -redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do - c' <- redIdent c - case info of - AbsCat (Yes cont) pfs -> do - let fs = case pfs of - Yes ts -> [(m,c) | Q m c <- ts] - _ -> [] - returns c' $ C.AbsCat cont fs - AbsFun (Yes typ) pdf -> do - let df = case pdf of - Yes t -> t -- definition or "data" - _ -> Eqs [] -- primitive notion - returns c' $ C.AbsFun typ df - AbsTrans t -> - returns c' $ C.AbsTrans t - - ResParam (Yes (ps,_)) -> do - ps' <- mapM redParam ps - returns c' $ C.ResPar ps' - - CncCat pty ptr ppr -> case (pty,ptr,ppr) of - (Yes ty, Yes (Abs _ t), Yes pr) -> do - ty' <- redCType ty - trm' <- redCTerm t - pr' <- redCTerm pr - return [(c', C.CncCat ty' trm' pr')] - _ -> prtBad ("cannot reduce rule for") c - - CncFun mt ptr ppr -> case (mt,ptr,ppr) of - (Just (cat,_), Yes trm, Yes pr) -> do - cat' <- redIdent cat - (xx,body,_) <- termForm trm - xx' <- mapM redArgvar xx - body' <- errIn (prt body) $ redCTerm body ---- debug - pr' <- redCTerm pr - return [(c',C.CncFun (G.CIQ am cat') xx' body' pr')] - _ -> prtBad ("cannot reduce rule" +++ show info +++ "for") c ---- debug - - AnyInd s b -> do - b' <- redIdent b - returns c' $ C.AnyInd s b' - - _ -> return [] --- retain some operations - where - returns f i = return [(f,i)] - -redQIdent :: QIdent -> Err G.CIdent -redQIdent (m,c) = return $ G.CIQ m c - -redIdent :: Ident -> Err Ident -redIdent x - | isWildIdent x = return $ identC "h_" --- needed in declarations - | otherwise = return $ identC $ prt x --- - -redFlag :: Option -> Err G.Flag -redFlag (Opt (f,[x])) = return $ G.Flg (identC f) (identC x) -redFlag o = Bad $ "cannot reduce option" +++ prOpt o - -redDecl :: Decl -> Err G.Decl -redDecl (x,a) = liftM2 G.Decl (redIdent x) (redType a) - -redType :: Type -> Err G.Exp -redType = redTerm - -redTerm :: Type -> Err G.Exp -redTerm t = return $ rtExp t - --- to normalize records and record types -sortByFst :: Ord a => [(a,b)] -> [(a,b)] -sortByFst = sortBy (\ x y -> compare (fst x) (fst y)) - --- resource - -redParam :: Param -> Err G.ParDef -redParam (c,cont) = do - c' <- redIdent c - cont' <- mapM (redCType . snd) cont - return $ G.ParD c' cont' - -redArgvar :: Ident -> Err G.ArgVar -redArgvar x = case x of - IA (x,i) -> return $ G.A (identC x) (toInteger i) - IAV (x,b,i) -> return $ G.AB (identC x) (toInteger b) (toInteger i) - _ -> Bad $ "cannot reduce" +++ show x +++ "as argument variable" - -redLindef :: Term -> Err G.Term -redLindef t = case t of - Abs x b -> redCTerm b --- - _ -> redCTerm t - -redCType :: Type -> Err G.CType -redCType t = case t of - RecType lbs -> do - let (ls,ts) = unzip lbs - ls' = map redLabel ls - ts' <- mapM redCType ts - return $ G.RecType $ map (uncurry G.Lbg) $ sortByFst $ zip ls' ts' - Table p v -> liftM2 G.Table (redCType p) (redCType v) - Q m c -> liftM G.Cn $ redQIdent (m,c) - QC m c -> liftM G.Cn $ redQIdent (m,c) - - App (Q (IC "Predef") (IC "Ints")) (EInt n) -> return $ G.TInts (toInteger n) - - Sort "Str" -> return $ G.TStr - Sort "Tok" -> return $ G.TStr - _ -> prtBad "cannot reduce to canonical the type" t - -redCTerm :: Term -> Err G.Term -redCTerm t = case t of - Vr x -> checkAgain - (liftM G.Arg $ redArgvar x) - (liftM G.LI $ redIdent x) --- for parametrize optimization - App _ s -> do -- only constructor applications can remain - (_,c,xx) <- termForm t - xx' <- mapM redCTerm xx - case c of - QC p c -> liftM2 G.Par (redQIdent (p,c)) (return xx') - Q (IC "Predef") (IC "error") -> fail $ "error: " ++ stringFromTerm s - _ -> prtBad "expected constructor head instead of" c - Q p c -> liftM G.I (redQIdent (p,c)) - QC p c -> liftM2 G.Par (redQIdent (p,c)) (return []) - R rs -> do - let (ls,tts) = unzip rs - ls' = map redLabel ls - ts <- mapM (redCTerm . snd) tts - return $ G.R $ map (uncurry G.Ass) $ sortByFst $ zip ls' ts - RecType [] -> return $ G.R [] --- comes out in parsing - P tr l -> do - tr' <- redCTerm tr - return $ G.P tr' (redLabel l) - PI tr l _ -> redCTerm $ P tr l ----- - T i cs -> do - ty <- getTableType i - ty' <- redCType ty - let (ps,ts) = unzip cs - ps' <- mapM redPatt ps - ts' <- mapM redCTerm ts - return $ G.T ty' $ map (uncurry G.Cas) $ zip (map singleton ps') ts' - TSh i cs -> do - ty <- getTableType i - ty' <- redCType ty - let (pss,ts) = unzip cs - pss' <- mapM (mapM redPatt) pss - ts' <- mapM redCTerm ts - return $ G.T ty' $ map (uncurry G.Cas) $ zip pss' ts' - V ty ts -> do - ty' <- redCType ty - ts' <- mapM redCTerm ts - return $ G.V ty' ts' - S u v -> liftM2 G.S (redCTerm u) (redCTerm v) - K s -> return $ G.K (G.KS s) - EInt i -> return $ G.EInt i - EFloat i -> return $ G.EFloat i - C u v -> liftM2 G.C (redCTerm u) (redCTerm v) - FV ts -> liftM G.FV $ mapM redCTerm ts ---- Ready ss -> return $ G.Ready [redStr ss] --- obsolete - - Alts (d,vs) -> do --- - d' <- redCTermTok d - vs' <- mapM redVariant vs - return $ G.K $ G.KP d' vs' - - Empty -> return $ G.E - ---- Strs ss -> return $ G.Strs [s | K s <- ss] --- - ----- Glue obsolete in canon, should not occur here - Glue x y -> redCTerm (C x y) - - _ -> Bad ("cannot reduce term" +++ prt t) - -redPatt :: Patt -> Err G.Patt -redPatt p = case p of - PP m c ps -> liftM2 G.PC (redQIdent (m,c)) (mapM redPatt ps) - PR rs -> do - let (ls,tts) = unzip rs - ls' = map redLabel ls - ts <- mapM redPatt tts - return $ G.PR $ map (uncurry G.PAss) $ sortByFst $ zip ls' ts - PT _ q -> redPatt q - PInt i -> return $ G.PI i - PFloat i -> return $ G.PF i - PV x -> liftM G.PV $ redIdent x --- for parametrize optimization - _ -> prtBad "cannot reduce pattern" p - -redLabel :: Label -> G.Label -redLabel (LIdent s) = G.L $ identC s -redLabel (LVar i) = G.LV $ toInteger i - -redVariant :: (Term, Term) -> Err G.Variant -redVariant (v,c) = do - v' <- redCTermTok v - c' <- redCTermTok c - return $ G.Var v' c' - -redCTermTok :: Term -> Err [String] -redCTermTok t = case t of - K s -> return [s] - Empty -> return [] - C a b -> liftM2 (++) (redCTermTok a) (redCTermTok b) - Strs ss -> return [s | K s <- ss] --- - _ -> prtBad "cannot get strings from term" t - diff --git a/src-3.0/GF/Compile/MkConcrete.hs b/src-3.0/GF/Compile/MkConcrete.hs deleted file mode 100644 index d016a7e47..000000000 --- a/src-3.0/GF/Compile/MkConcrete.hs +++ /dev/null @@ -1,154 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : MkConcrete --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: --- > CVS $Author: --- > CVS $Revision: --- --- Compile a gfe file into a concrete syntax by using the parser on a resource grammar. ------------------------------------------------------------------------------ - -module GF.Compile.MkConcrete (mkConcretes) where - -import GF.Grammar.Values (Tree,tree2exp) -import GF.Grammar.PrGrammar (prt_,prModule) -import GF.Grammar.Grammar --- (Term(..),SourceModule) -import GF.Grammar.Macros (composSafeOp, composOp, record2subst, zIdent) -import GF.Compile.ShellState --(firstStateGrammar,stateGrammarWords) -import GF.Compile.PGrammar (pTerm,pTrm) -import GF.Compile.Compile -import GF.Compile.PrOld (stripTerm) -import GF.Compile.GetGrammar -import GF.API -import GF.API.IOGrammar -import qualified GF.Embed.EmbedAPI as EA - -import GF.Data.Operations -import GF.Infra.UseIO -import GF.Infra.Option -import GF.Infra.Modules -import GF.Infra.ReadFiles -import GF.System.Arch -import GF.UseGrammar.Treebank - -import System.Directory -import System.FilePath -import Data.Char -import Control.Monad -import Data.List - --- translate strings into lin rules by parsing in a resource --- grammar. AR 2/6/2005 - --- Format of rule (on one line): --- lin F x y = in C "ssss" ; --- Format of resource path (on first line): --- --# -resource=PATH --- Other lines are copied verbatim. --- A sequence of files can be processed with the same resource without --- rebuilding the grammar and parser. - --- notice: we use a hand-crafted lexer and parser in order to preserve --- the layout and comments in the rest of the file. - -mkConcretes :: Options -> [FilePath] -> IO () -mkConcretes opts files = do - ress <- mapM getResPath files - let grps = groupBy (\a b -> fst a == fst b) $ - sortBy (\a b -> compare (fst a) (fst b)) $ zip ress files - mapM_ (mkCncGroups opts) [(rp,map snd gs) | gs@((rp,_):_) <- grps] - -mkCncGroups opts0 ((res,path),files) = do - putStrLnFlush $ "Going to preprocess examples in " ++ unwords files - putStrLn $ "Compiling resource " ++ res - let opts = addOptions (options [beSilent,pathList path]) opts0 - let treebank = oElem (iOpt "treebank") opts - resf <- useIOE res $ do - (fp,_) <- readFileLibraryIOE "" res - return fp - egr <- appIOE $ shellStateFromFiles opts emptyShellState resf - (parser,morpho) <- if treebank then do - tb <- err (\_ -> error $ "no treebank of name" +++ path) - return - (egr >>= flip findTreebank (zIdent path)) - return (\_ -> flip (,) "Not in treebank" . map pTrm . lookupTreebank tb, - isWordInTreebank tb) - else do - gr <- err (\s -> putStrLn s >> error "resource grammar rejected") - (return . firstStateGrammar) egr - return - (\cat s -> - errVal ([],"No parse") $ - optParseArgErrMsg (options [newFParser, firstCat cat, beVerbose]) gr s >>= - (\ (ts,e) -> return (map tree2exp ts, e)) , - isKnownWord gr) - putStrLn "Building parser" - mapM_ (mkConcrete parser morpho) files - -type Parser = String -> String -> ([Term],String) -type Morpho = String -> Bool - -getResPath :: FilePath -> IO (String,String) -getResPath file = do - s <- liftM lines $ readFileIf file - case filter (not . all isSpace) s of - res:path:_ | is "resource" res && is "path" path -> return (val res, val path) - res:path:_ | is "resource" res && is "treebank" path -> return (val res, val path) - res:_ | is "resource" res -> return (val res, "") - _ -> error - "expected --# -resource=FILE and optional --# -path=PATH or --# -treebank=IDENT" - where - val = dropWhile (isSpace) . tail . dropWhile (not . (=='=')) - is tag s = case words s of - "--#":w:_ -> isPrefixOf ('-':tag) w - _ -> False - - -mkConcrete :: Parser -> Morpho -> FilePath -> IO () -mkConcrete parser morpho file = do - src <- appIOE (getSourceModule noOptions file) >>= err error return - let (src',msgs) = mkModule parser morpho src - let out = addExtension (justModuleName file) "gf" - writeFile out $ "-- File generated by GF from " ++ file - appendFile out "\n" - appendFile out (prModule src') - appendFile out "{-\n" - appendFile out $ unlines $ filter (not . null) msgs - appendFile out "-}\n" - -mkModule :: Parser -> Morpho -> SourceModule -> (SourceModule,[String]) -mkModule parser morpho (name,src) = case src of - ModMod m@(Module mt st fs me ops js) -> - - let js1 = jments m - (js2,msgs) = err error id $ appSTM (mapMTree mkInfo js1) [] - mod2 = ModMod $ Module mt st fs me ops $ js2 - in ((name,mod2), msgs) - where - mkInfo ni@(name,info) = case info of - CncFun mt (Yes trm) ppr -> do - trm' <- mkTrm trm - return (name, CncFun mt (Yes trm') ppr) - _ -> return ni - where - mkTrm t = case t of - Example (P _ cat) s -> parse cat s t - Example (Vr cat) s -> parse cat s t - _ -> composOp mkTrm t - parse cat s t = case parser (prt_ cat) s of - (tr:[], _) -> do - updateSTM ((("PARSED in" +++ prt_ name) : s : [prt_ tr]) ++) - return $ stripTerm tr - (tr:trs,_) -> do - updateSTM ((("AMBIGUOUS in" +++ prt_ name) : s : map prt_ trs) ++) - return $ stripTerm tr - ([],ms) -> do - updateSTM ((("NO PARSE in" +++ prt_ name) : s : ms : [morph s]) ++) - return t - morph s = case [w | w <- words s, not (morpho w)] of - [] -> "" - ws -> "unknown words: " ++ unwords ws diff --git a/src-3.0/GF/Compile/MkResource.hs b/src-3.0/GF/Compile/MkResource.hs deleted file mode 100644 index 10831b5c6..000000000 --- a/src-3.0/GF/Compile/MkResource.hs +++ /dev/null @@ -1,128 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : MkResource --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/30 21:08:14 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.14 $ --- --- Compile a gfc module into a "reuse" gfr resource, interface, or instance. ------------------------------------------------------------------------------ - -module GF.Compile.MkResource (makeReuse) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.Macros -import GF.Grammar.Lockfield -import GF.Grammar.PrGrammar - -import GF.Data.Operations - -import Control.Monad - --- | extracting resource r from abstract + concrete syntax. --- AR 21\/8\/2002 -- 22\/6\/2003 for GF with modules -makeReuse :: SourceGrammar -> Ident -> [(Ident,MInclude Ident)] -> - MReuseType Ident -> Err SourceRes -makeReuse gr r me mrc = do - flags <- return [] --- no flags are passed: they would not make sense - case mrc of - MRResource c -> do - (ops,jms) <- mkFull True c - return $ Module MTResource MSComplete flags me ops jms - - MRInstance c a -> do - (ops,jms) <- mkFull False c - return $ Module (MTInstance a) MSComplete flags me ops jms - - MRInterface c -> do - mc <- lookupModule gr c - - (ops,jms) <- case mc of - ModMod m -> case mtype m of - MTAbstract -> liftM ((,) (opens m)) $ - mkResDefs True False gr r c me - (extend m) (jments m) emptyBinTree - _ -> prtBad "expected abstract to be the type of" c - _ -> prtBad "expected abstract to be the type of" c - - return $ Module MTInterface MSIncomplete flags me ops jms - - where - mkFull hasT c = do - mc <- lookupModule gr c - - case mc of - ModMod m -> case mtype m of - MTConcrete a -> do - ma <- lookupModule gr a - jmsA <- case ma of - ModMod m' -> return $ jments m' - _ -> prtBad "expected abstract to be the type of" a - liftM ((,) (opens m)) $ - mkResDefs hasT True gr r a me (extend m) jmsA (jments m) - _ -> prtBad "expected concrete to be the type of" c - _ -> prtBad "expected concrete to be the type of" c - - --- | the first Boolean indicates if the type needs be given --- the second Boolean indicates if the definition needs be given -mkResDefs :: Bool -> Bool -> - SourceGrammar -> Ident -> Ident -> - [(Ident,MInclude Ident)] -> [(Ident,MInclude Ident)] -> - BinTree Ident Info -> BinTree Ident Info -> - Err (BinTree Ident Info) -mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs where - - ifTyped = yes --- if hasT then yes else const nope --- needed for TC - ifCompl = if isC then yes else const nope - doIf b t = if b then t else return typeType -- latter value not used - - mkOne a mae (f,info) = case info of - AbsCat _ _ -> do - typ <- doIf isC $ err (const (return defLinType)) return $ look cnc f - typ' <- doIf isC $ lockRecType f typ - return (f, ResOper (ifTyped typeType) (ifCompl typ')) - AbsFun (Yes typ0) _ -> do - trm <- doIf isC $ look cnc f - testErr (not (isHardType typ0)) - ("cannot build reuse for function" +++ prt f +++ ":" +++ prt typ0) - typ <- redirTyp True a mae typ0 - cat <- valCat typ - trm' <- doIf isC $ unlockRecord (snd cat) trm - return (f, ResOper (ifTyped typ) (ifCompl trm')) - AnyInd b n -> do - mo <- lookupModMod gr n - info' <- lookupInfo mo f - mkOne n (extend mo) (f,info') - - look cnc f = do - info <- lookupTree prt f cnc - case info of - CncCat (Yes ty) _ _ -> return ty - CncCat _ _ _ -> return defLinType - CncFun _ (Yes tr) _ -> return tr - AnyInd _ n -> do - mo <- lookupModMod gr n - t <- look (jments mo) f - redirTyp False n (extend mo) t - _ -> prtBad "not enough information to reuse" f - - -- type constant qualifications changed from abstract to resource - redirTyp always a mae ty = case ty of - Q _ c | always -> return $ Q r c - Q n c | n == a || [n] == map fst mae -> return $ Q r c ---- FIX for non-singleton exts - _ -> composOp (redirTyp always a mae) ty - --- | no reuse for functions of HO\/dep types -isHardType t = case t of - Prod x a b -> not (isWild x) || isHardType a || isHardType b - App _ _ -> True - _ -> False - where - isWild x = isWildIdent x || prt x == "h_" --- produced by transl from canon diff --git a/src-3.0/GF/Compile/MkUnion.hs b/src-3.0/GF/Compile/MkUnion.hs deleted file mode 100644 index b4b1f40c8..000000000 --- a/src-3.0/GF/Compile/MkUnion.hs +++ /dev/null @@ -1,83 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : MkUnion --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:39 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.7 $ --- --- building union of modules. --- AR 1\/3\/2004 --- OBSOLETE 15\/9\/2004 with multiple inheritance ------------------------------------------------------------------------------ - -module GF.Compile.MkUnion (makeUnion) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.Macros -import GF.Grammar.PrGrammar - -import GF.Data.Operations -import GF.Infra.Option - -import Data.List -import Control.Monad - -makeUnion :: SourceGrammar -> Ident -> ModuleType Ident -> [(Ident,[Ident])] -> - Err SourceModule -makeUnion gr m ty imps = do - ms <- mapM (lookupModMod gr . fst) imps - typ <- return ty ---- getTyp ms - ext <- getExt [i | Just i <- map extends ms] - ops <- return $ nub $ concatMap opens ms - flags <- return $ concatMap flags ms - js <- liftM (buildTree . concat) $ mapM getJments imps - return $ (m, ModMod (Module typ MSComplete flags ext ops js)) - - where - getExt es = case es of - [] -> return Nothing - i:is -> if all (==i) is then return (Just i) - else Bad "different extended modules in union forbidden" - getJments (i,fs) = do - m <- lookupModMod gr i - let js = jments m - if null fs - then - return (map (unqual i) $ tree2list js) - else do - ds <- mapM (flip justLookupTree js) fs - return $ map (unqual i) $ zip fs ds - - unqual i (f,d) = curry id f $ case d of - AbsCat pty pts -> AbsCat (qualCo pty) (qualPs pts) - AbsFun pty pt -> AbsFun (qualP pty) (qualP pt) - AbsTrans t -> AbsTrans $ qual t - ResOper pty pt -> ResOper (qualP pty) (qualP pt) - CncCat pty pt pp -> CncCat (qualP pty) (qualP pt) (qualP pp) - CncFun mp pt pp -> CncFun (qualLin mp) (qualP pt) (qualP pp) ---- mp - ResParam (Yes ps) -> ResParam (yes (map qualParam ps)) - ResValue pty -> ResValue (qualP pty) - _ -> d - where - qualP pt = case pt of - Yes t -> yes $ qual t - _ -> pt - qualPs pt = case pt of - Yes ts -> yes $ map qual ts - _ -> pt - qualCo pco = case pco of - Yes co -> yes $ [(x,qual t) | (x,t) <- co] - _ -> pco - qual t = case t of - Q m c | m==i -> Cn c - QC m c | m==i -> Cn c - _ -> composSafeOp qual t - qualParam (p,co) = (p,[(x,qual t) | (x,t) <- co]) - qualLin (Just (c,(co,t))) = (Just (c,([(x,qual t) | (x,t) <- co], qual t))) - qualLin Nothing = Nothing - diff --git a/src-3.0/GF/Compile/NewRename.hs b/src-3.0/GF/Compile/NewRename.hs deleted file mode 100644 index cec8ed24f..000000000 --- a/src-3.0/GF/Compile/NewRename.hs +++ /dev/null @@ -1,294 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:41 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- AR 14\/5\/2003 --- --- The top-level function 'renameGrammar' does several things: --- --- - extends each module symbol table by indirections to extended module --- --- - changes unqualified and as-qualified imports to absolutely qualified --- --- - goes through the definitions and resolves names --- --- Dependency analysis between modules has been performed before this pass. --- Hence we can proceed by @fold@ing "from left to right". ------------------------------------------------------------------------------ - -module GF.Compile.NewRename (renameSourceTerm, renameModule) where - -import GF.Grammar.Grammar -import GF.Grammar.Values -import GF.Infra.Modules -import GF.Infra.Ident -import GF.Grammar.Macros -import GF.Grammar.PrGrammar -import GF.Grammar.AppPredefined -import GF.Grammar.Lookup -import GF.Compile.Extend -import GF.Data.Operations - -import Control.Monad - --- | this gives top-level access to renaming term input in the cc command -renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term -renameSourceTerm g m t = do - mo <- lookupErr m (modules g) - let status = (modules g,(m,mo)) --- <- buildStatus g m mo - renameTerm status [] t - --- | this is used in the compiler, separately for each module -renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule] -renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of - ModMod m@(Module mt st fs me ops js) -> do - let js1 = jments m - let status = (ms, (name, mod)) - js2 <- mapMTree (renameInfo status) js1 - let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2 - return $ (name,mod2) : ms - -type Status = ([SourceModule],SourceModule) --- (StatusTree, [(OpenSpec Ident, StatusTree)]) - ---- type StatusTree = BinTree (Ident,StatusInfo) - ---- type StatusInfo = Ident -> Term - -lookupStatusInfo :: Ident -> SourceModule -> Err Term -lookupStatusInfo c (q,ModMod m) = do - i <- lookupTree prt c $ jments m - return $ case i of - AbsFun _ (Yes EData) -> QC q c - ResValue _ -> QC q c - ResParam _ -> QC q c - AnyInd True n -> QC n c --- should go further? - AnyInd False n -> Q n c - _ -> Q q c -lookupStatusInfo c (q,_) = prtBad "ModMod expected for" q - -lookupStatusInfoMany :: [SourceModule] -> Ident -> Err Term -lookupStatusInfoMany (m:ms) c = case lookupStatusInfo c m of - Ok v -> return v - _ -> lookupStatusInfoMany ms c -lookupStatusInfoMany [] x = - prtBad "renaming failed to find unqualified constant" x ----- should also give error if stg is found in more than one module - -renameIdentTerm :: Status -> Term -> Err Term -renameIdentTerm env@(imps,act@(_,ModMod this)) t = - errIn ("atomic term" +++ prt t +++ "given" +++ unwords (map (prt . fst) qualifs)) $ - case t of - Vr c -> do - f <- err (predefAbs c) return $ lookupStatusInfoMany openeds c - return $ f - Cn c -> do - f <- lookupStatusInfoMany openeds c - return $ f - Q m' c | m' == cPredef {- && isInPredefined c -} -> return t - Q m' c -> do - m <- lookupErr m' qualifs - f <- lookupStatusInfo c m - return $ f - QC m' c | m' == cPredef {- && isInPredefined c -} -> return t - QC m' c -> do - m <- lookupErr m' qualifs - f <- lookupStatusInfo c m - return $ f - _ -> return t - where - openeds = act : [(m,st) | OSimple _ m <- opens this, Just st <- [lookup m imps]] - qualifs = - [(m, (n,st)) | OQualif _ m n <- opens this, Just st <- [lookup n imps]] - ++ - [(m, (m,st)) | OSimple _ m <- opens this, Just st <- [lookup m imps]] - -- qualif is always possible - - -- this facility is mainly for BWC with GF1: you need not import PredefAbs - predefAbs c s = case c of - IC "Int" -> return $ Q cPredefAbs cInt - IC "String" -> return $ Q cPredefAbs cString - _ -> Bad s - --- | would it make sense to optimize this by inlining? -renameIdentPatt :: Status -> Patt -> Err Patt -renameIdentPatt env p = do - let t = patt2term p - t' <- renameIdentTerm env t - term2patt t' - -{- deprec ! -info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo) -info2status mq (c,i) = (c, 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 - OSimple _ i -> mapTree (info2status (Just i)) - OQualif _ i j -> mapTree (info2status (Just j)) - -buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status -buildStatus gr c mo = let mo' = self2status c mo in case mo of - ModMod m -> do - let gr1 = MGrammar $ (c,mo) : modules gr - ops = [OSimple OQNormal e | e <- allExtendsPlus gr1 c] ++ allOpens m - mods <- mapM (lookupModule gr1 . openedModule) ops - let sts = map modInfo2status $ zip ops mods - return $ if isModCnc m - then (NT, reverse sts) -- the module itself does not define any names - else (mo',reverse sts) -- so the empty ident is not needed - -modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree) -modInfo2status (o,i) = (o,case i of - ModMod m -> tree2status o (jments m) - ) - -self2status :: Ident -> SourceModInfo -> StatusTree -self2status c i = mapTree (info2status (Just c)) js where -- qualify internal - js = case i of - ModMod m - | isModTrans m -> sorted2tree $ filter noTrans $ tree2list $ jments m - | otherwise -> jments m - noTrans (_,d) = case d of -- to enable other than transfer js in transfer module - AbsTrans _ -> False - _ -> True --} - -forceQualif o = case o of - OSimple q i -> OQualif q i i - OQualif q _ i -> OQualif q i i - -renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info) -renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $ - liftM ((,) i) $ case info of - AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco) - (renPerh (mapM rent) pfs) - AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr) - AbsTrans f -> liftM AbsTrans (rent f) - - ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr) - ResParam pp -> liftM ResParam (renPerh (mapM (renameParam status)) pp) - ResValue t -> liftM ResValue (ren t) - 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 = renPerh rent - rent = renameTerm status [] - -renPerh ren pt = case pt of - Yes t -> liftM Yes $ ren t - _ -> return pt - -renameTerm :: Status -> [Ident] -> Term -> Err Term -renameTerm env vars = ren vars where - ren vs trm = case trm of - Abs x b -> liftM (Abs x) (ren (x:vs) b) - Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b) - Typed a b -> liftM2 Typed (ren vs a) (ren vs b) - Vr x - | elem x vs -> return trm - | otherwise -> renid trm - Cn _ -> renid trm - Con _ -> renid trm - Q _ _ -> renid trm - QC _ _ -> renid trm - Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs - T i cs -> do - i' <- case i of - TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source - _ -> return i - liftM (T i') $ mapM (renCase vs) cs - - Let (x,(m,a)) b -> do - m' <- case m of - Just ty -> liftM Just $ ren vs ty - _ -> return m - a' <- ren vs a - b' <- ren (x:vs) b - return $ Let (x,(m',a')) b' - - P t@(Vr r) l -- for constant t we know it is projection - | elem r vs -> return trm -- var proj first - | otherwise -> case renid (Q r (label2ident l)) of -- qualif second - Ok t -> return t - _ -> liftM (flip P l) $ renid t -- const proj last - - _ -> composOp (ren vs) trm - - renid = renameIdentTerm env - renCase vs (p,t) = do - (p',vs') <- renpatt p - t' <- ren (vs' ++ vs) t - return (p',t') - renpatt = renamePattern env - --- | vars not needed in env, since patterns always overshadow old vars -renamePattern :: Status -> Patt -> Err (Patt,[Ident]) -renamePattern env patt = case patt of - - PC c ps -> do - c' <- renameIdentTerm env $ Cn c - psvss <- mapM renp ps - let (ps',vs) = unzip psvss - case c' of - QC p d -> return (PP p d ps', concat vs) - Q p d -> return (PP p d ps', concat vs) ---- should not happen - _ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs) - ----- PP p c ps -> (PP p c ps',concat vs') where (ps',vs') = unzip $ map renp ps - - PV x -> case renid patt of - Ok p -> return (p,[]) - _ -> return (patt, [x]) - - PR r -> do - let (ls,ps) = unzip r - psvss <- mapM renp ps - let (ps',vs') = unzip psvss - return (PR (zip ls ps'), concat vs') - - _ -> return (patt,[]) - - where - renp = renamePattern env - renid = renameIdentPatt env - -renameParam :: Status -> (Ident, Context) -> Err (Ident, Context) -renameParam env (c,co) = do - co' <- renameContext env co - return (c,co') - -renameContext :: Status -> Context -> Err Context -renameContext b = renc [] where - renc vs cont = case cont of - (x,t) : xts - | isWildIdent x -> do - t' <- ren vs t - xts' <- renc vs xts - return $ (x,t') : xts' - | otherwise -> do - t' <- ren vs t - let vs' = x:vs - xts' <- renc vs' xts - return $ (x,t') : xts' - _ -> return cont - ren = renameTerm b - --- | vars not needed in env, since patterns always overshadow old vars -renameEquation :: Status -> [Ident] -> Equation -> Err Equation -renameEquation b vs (ps,t) = do - (ps',vs') <- liftM unzip $ mapM (renamePattern b) ps - t' <- renameTerm b (concat vs' ++ vs) t - return (ps',t') diff --git a/src-3.0/GF/Compile/NoParse.hs b/src-3.0/GF/Compile/NoParse.hs deleted file mode 100644 index c8f828970..000000000 --- a/src-3.0/GF/Compile/NoParse.hs +++ /dev/null @@ -1,49 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : NoParse --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/14 16:03:41 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.1 $ --- --- Probabilistic abstract syntax. AR 30\/10\/2005 --- --- (c) Aarne Ranta 2005 under GNU GPL --- --- Contents: decide what lin rules no parser is generated. --- Usually a list of noparse idents from 'i -boparse=file'. - ------------------------------------------------------------------------------ - -module GF.Compile.NoParse ( - NoParse -- = Ident -> Bool - ,getNoparseFromFile -- :: Opts -> IO NoParse - ,doParseAll -- :: NoParse - ) where - -import GF.Infra.Ident -import GF.Data.Operations -import GF.Infra.Option - - -type NoParse = (Ident -> Bool) - -doParseAll :: NoParse -doParseAll = const False - -getNoparseFromFile :: Options -> FilePath -> IO NoParse -getNoparseFromFile opts file = do - let f = maybe file id $ getOptVal opts noparseFile - s <- readFile f - let tree = buildTree $ flip zip (repeat ()) $ concat $ map getIgnores $ lines s - tree `seq` return $ igns tree - where - igns tree i = isInBinTree i tree - --- where -getIgnores s = case dropWhile (/="--#") (words s) of - _:"noparse":fs -> map identC fs - _ -> [] diff --git a/src-3.0/GF/Compile/Optimize.hs b/src-3.0/GF/Compile/Optimize.hs deleted file mode 100644 index 8931cb6a2..000000000 --- a/src-3.0/GF/Compile/Optimize.hs +++ /dev/null @@ -1,300 +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 - -import Debug.Trace - - --- conditional trace - -prtIf :: (Print a) => Bool -> a -> a -prtIf b t = if b then trace (" " ++ prt t) t else t - --- experimental evaluation, option to import -oEval = iOpt "eval" - --- | 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)],EEnv) -> - (Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv) -optimizeModule opts 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 | oElem oEval oopts -> do - (js0,eenv') <- appEvalConcrete gr js eenv - js' <- mapMTree (evalCncInfo oopts gr name a) js0 ---- <- gr0 6/12/2005 - return $ ((name, ModMod (Module mt st fs me ops js')),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 ([(varStr, typeStr)], typ) de - (Yes typ, Nope) -> - liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(varStr, 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 varStr . 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 varStr - 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-3.0/GF/Compile/PGrammar.hs b/src-3.0/GF/Compile/PGrammar.hs deleted file mode 100644 index 521f616b5..000000000 --- a/src-3.0/GF/Compile/PGrammar.hs +++ /dev/null @@ -1,77 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/25 10:27:12 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Compile.PGrammar (pTerm, pTrm, pTrms, - pMeta, pzIdent, - string2ident - ) where - ----import LexGF -import GF.Source.ParGF -import GF.Source.SourceToGrammar (transExp) -import GF.Grammar.Grammar -import GF.Infra.Ident -import qualified GF.Canon.AbsGFC as A -import qualified GF.Canon.GFC as G -import GF.Compile.GetGrammar -import GF.Grammar.Macros -import GF.Grammar.MMacros - -import GF.Data.Operations -import qualified Data.ByteString.Char8 as BS - -pTerm :: String -> Err Term -pTerm s = do - e <- pExp $ myLexer (BS.pack s) - transExp e - -pTrm :: String -> Term -pTrm = errVal (vr (zIdent "x")) . pTerm --- - -pTrms :: String -> [Term] -pTrms = map pTrm . sep [] where - sep t cs = case cs of - ',' : cs2 -> reverse t : sep [] cs2 - c : cs2 -> sep (c:t) cs2 - _ -> [reverse t] - -pTrm' :: String -> [Term] -pTrm' = err (const []) singleton . pTerm - -pMeta :: String -> Integer -pMeta _ = 0 --- - -pzIdent :: String -> Ident -pzIdent = zIdent - -{- -string2formsAndTerm :: String -> ([Term],Term) -string2formsAndTerm s = case s of - '[':_:_ -> case span (/=']') s of - (x,_:y) -> (pTrms (tail x), pTrm y) - _ -> ([],pTrm s) - _ -> ([], pTrm s) --} - -string2ident :: String -> Err Ident -string2ident s = return $ string2var s - -{- --- reads the Haskell datatype -readGrammar :: String -> Err GrammarST -readGrammar s = case [x | (x,t) <- reads s, ("","") <- lex t] of - [x] -> return x - [] -> Bad "no parse of Grammar" - _ -> Bad "ambiguous parse of Grammar" --} diff --git a/src-3.0/GF/Compile/PrOld.hs b/src-3.0/GF/Compile/PrOld.hs deleted file mode 100644 index 29920fab6..000000000 --- a/src-3.0/GF/Compile/PrOld.hs +++ /dev/null @@ -1,84 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrOld --- Maintainer : GF --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:44 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- a hack to print gf2 into gf1 readable files --- Works only for canonical grammars, printed into GFC. Otherwise we would have --- problems with qualified names. --- --- printnames are not preserved, nor are lindefs ------------------------------------------------------------------------------ - -module GF.Compile.PrOld (printGrammarOld, stripTerm) where - -import GF.Grammar.PrGrammar -import GF.Canon.CanonToGrammar -import qualified GF.Canon.GFC as GFC -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Grammar.Macros -import GF.Infra.Modules -import qualified GF.Source.PrintGF as P -import GF.Source.GrammarToSource - -import Data.List -import GF.Data.Operations -import GF.Infra.UseIO - -printGrammarOld :: GFC.CanonGrammar -> String -printGrammarOld gr = err id id $ do - as0 <- mapM canon2sourceModule [im | im@(_,ModMod m) <- modules gr, isModAbs m] - cs0 <- mapM canon2sourceModule - [im | im@(_,ModMod m) <- modules gr, isModCnc m || isModRes m] - as1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) as0 - cs1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) cs0 - return $ unlines $ map prj $ srt as1 ++ srt cs1 - where - js (ModMod m) = jments m - srt = sortBy (\ (i,_) (j,_) -> compare i j) - prj ii = P.printTree $ trAnyDef ii - -stripInfo :: (Ident,Info) -> [(Ident,Info)] -stripInfo (c,i) = case i of - AbsCat (Yes co) (Yes fs) -> rc $ AbsCat (Yes (stripContext co)) nope - AbsFun (Yes ty) (Yes tr) -> rc $ AbsFun (Yes (stripTerm ty)) (Yes(stripTerm tr)) - AbsFun (Yes ty) _ -> rc $ AbsFun (Yes (stripTerm ty)) nope - ResParam (Yes (ps,m)) -> rc $ ResParam (Yes ([(c,stripContext co) | (c,co)<- ps],Nothing)) - CncCat (Yes ty) _ _ -> rc $ - CncCat (Yes (stripTerm ty)) nope nope - CncFun _ (Yes tr) _ -> rc $ CncFun Nothing (Yes (stripTerm tr)) nope - _ -> [] - where - rc j = [(c,j)] - -stripContext co = [(x, stripTerm t) | (x,t) <- co] - -stripTerm :: Term -> Term -stripTerm t = case t of - Q _ c -> Vr c - QC _ c -> Vr c - T ti cs -> T ti' [(stripPattern p, stripTerm c) | (p,c) <- cs] where - ti' = case ti of - TTyped ty -> TTyped $ stripTerm ty - TComp ty -> TComp $ stripTerm ty - TWild ty -> TWild $ stripTerm ty - _ -> ti ----- R [] -> EInt 8 --- GF 1.2 parser doesn't accept empty records ----- RecType [] -> Cn (zIdent "Int") --- - _ -> composSafeOp stripTerm t - -stripPattern p = case p of - PC c [] -> PV c - PP _ c [] -> PV c - PC c ps -> PC c (map stripPattern ps) - PP _ c ps -> PC c (map stripPattern ps) - PR lps -> PR [(l, stripPattern p) | (l,p) <- lps] - PT t p -> PT (stripTerm t) (stripPattern p) - _ -> p - diff --git a/src-3.0/GF/Compile/ShellState.hs b/src-3.0/GF/Compile/ShellState.hs deleted file mode 100644 index 0e24da601..000000000 --- a/src-3.0/GF/Compile/ShellState.hs +++ /dev/null @@ -1,568 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ShellState --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/14 16:03:41 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.53 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Compile.ShellState where - -import GF.Data.Operations -import GF.Canon.GFC -import GF.Canon.AbsGFC -import GF.GFCC.CId ---import GF.GFCC.DataGFCC(mkGFCC) -import GF.GFCC.Macros (lookFCFG) -import GF.Canon.CanonToGFCC -import GF.Grammar.Macros -import GF.Grammar.MMacros - -import GF.Canon.Look -import GF.Canon.Subexpressions -import GF.Grammar.LookAbs -import GF.Compile.ModDeps -import GF.Compile.Evaluate -import qualified GF.Infra.Modules as M -import qualified GF.Grammar.Grammar as G -import qualified GF.Grammar.PrGrammar as P -import GF.CF.CF -import GF.CF.CFIdent -import GF.CF.CanonToCF -import GF.UseGrammar.Morphology -import GF.Probabilistic.Probabilistic -import GF.Compile.NoParse -import GF.Infra.Option -import GF.Infra.Ident -import GF.Infra.UseIO (justModuleName) -import GF.System.Arch (ModTime) - -import qualified Transfer.InterpreterAPI as T - -import GF.Formalism.FCFG -import qualified GF.OldParsing.ConvertGrammar as CnvOld -- OBSOLETE -import qualified GF.Conversion.GFC as Cnv -import qualified GF.Conversion.SimpleToFCFG as FCnv -import qualified GF.Parsing.GFC as Prs - -import Control.Monad (mplus) -import Data.List (nub,nubBy) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) - - --- AR 11/11/2001 -- 17/6/2003 (for modules) ---- unfinished - --- | multilingual state with grammars and options -data ShellState = ShSt { - abstract :: Maybe Ident , -- ^ pointer to actual abstract, if not empty st - concrete :: Maybe Ident , -- ^ pointer to primary concrete - concretes :: [((Ident,Ident),Bool)], -- ^ list of all concretes, and whether active - canModules :: CanonGrammar , -- ^ compiled abstracts and concretes - srcModules :: G.SourceGrammar , -- ^ saved resource modules - cfs :: [(Ident,CF)] , -- ^ context-free grammars (small, no parameters, very over-generating) - abstracts :: [(Ident,[Ident])], -- ^ abstracts and their associated concretes - mcfgs :: [(Ident, Cnv.MGrammar)], -- ^ MCFG, converted according to Ljunglöf (2004, ch 3) - fcfgs :: [(Ident, FGrammar)], -- ^ FCFG, optimized MCFG by Krasimir Angelov - cfgs :: [(Ident, Cnv.CGrammar)], -- ^ CFG, converted from mcfg - -- (large, with parameters, no-so overgenerating) - pInfos :: [(Ident, Prs.PInfo)], -- ^ parsing information (compiled mcfg&cfg grammars) - morphos :: [(Ident,Morpho)], -- ^ morphologies - treebanks :: [(Ident,Treebank)], -- ^ treebanks - probss :: [(Ident,Probs)], -- ^ probability distributions - gloptions :: Options, -- ^ global options - readFiles :: [(String,(FilePath,ModTime))],-- ^ files read - absCats :: [(G.Cat,(G.Context, - [(G.Fun,G.Type)], - [((G.Fun,Int),G.Type)]))], -- ^ cats, (their contexts, - -- functions to them, - -- functions on them) - statistics :: [Statistics], -- ^ statistics on grammars - transfers :: [(Ident,T.Env)], -- ^ transfer modules - evalEnv :: EEnv -- ^ evaluation environment - } - -type Treebank = Map.Map String [String] -- string, trees - -actualConcretes :: ShellState -> [((Ident,Ident),Bool)] -actualConcretes sh = nub [((c,c),b) | - Just a <- [abstract sh], - ((c,_),_) <- concretes sh, ----concretesOfAbstract sh a, - let b = True ----- - ] - -concretesOfAbstract :: ShellState -> Ident -> [Ident] -concretesOfAbstract sh a = [c | (b,cs) <- abstracts sh, b == a, c <- cs] - -data Statistics = - StDepTypes Bool -- ^ whether there are dependent types - | StBoundVars [G.Cat] -- ^ which categories have bound variables - --- -- etc - deriving (Eq,Ord) - -emptyShellState :: ShellState -emptyShellState = ShSt { - abstract = Nothing, - concrete = Nothing, - concretes = [], - canModules = M.emptyMGrammar, - srcModules = M.emptyMGrammar, - cfs = [], - abstracts = [], - mcfgs = [], - fcfgs = [], - cfgs = [], - pInfos = [], - morphos = [], - treebanks = [], - probss = [], - gloptions = noOptions, - readFiles = [], - absCats = [], - statistics = [], - transfers = [], - evalEnv = emptyEEnv - } - -optInitShellState :: Options -> ShellState -optInitShellState os = addGlobalOptions os emptyShellState - -type Language = Ident - -language :: String -> Language -language = identC - -prLanguage :: Language -> String -prLanguage = prIdent - --- | grammar for one language in a state, comprising its abs and cnc -data StateGrammar = StGr { - absId :: Ident, - cncId :: Ident, - grammar :: CanonGrammar, - cf :: CF, - mcfg :: Cnv.MGrammar, - fcfg :: FGrammar, - cfg :: Cnv.CGrammar, - pInfo :: Prs.PInfo, - morpho :: Morpho, - probs :: Probs, - loptions :: Options - } - -emptyStateGrammar :: StateGrammar -emptyStateGrammar = StGr { - absId = identC "#EMPTY", --- - cncId = identC "#EMPTY", --- - grammar = M.emptyMGrammar, - cf = emptyCF, - mcfg = [], - fcfg = ([], Map.empty), - cfg = [], - pInfo = Prs.buildPInfo [] ([], Map.empty) [], - morpho = emptyMorpho, - probs = emptyProbs, - loptions = noOptions - } - --- analysing shell grammar into parts - -stateGrammarST :: StateGrammar -> CanonGrammar -stateCF :: StateGrammar -> CF -stateMCFG :: StateGrammar -> Cnv.MGrammar -stateFCFG :: StateGrammar -> FGrammar -stateCFG :: StateGrammar -> Cnv.CGrammar -statePInfo :: StateGrammar -> Prs.PInfo -stateMorpho :: StateGrammar -> Morpho -stateProbs :: StateGrammar -> Probs -stateOptions :: StateGrammar -> Options -stateGrammarWords :: StateGrammar -> [String] -stateGrammarLang :: StateGrammar -> (CanonGrammar, Ident) - -stateGrammarST = grammar -stateCF = cf -stateMCFG = mcfg -stateFCFG = fcfg -stateCFG = cfg -statePInfo = pInfo -stateMorpho = morpho -stateProbs = probs -stateOptions = loptions -stateGrammarWords = allMorphoWords . stateMorpho -stateGrammarLang st = (grammar st, cncId st) - ----- this should be computed at compile time and stored -stateHasHOAS :: StateGrammar -> Bool -stateHasHOAS = hasHOAS . stateGrammarST - -cncModuleIdST :: StateGrammar -> CanonGrammar -cncModuleIdST = stateGrammarST - --- | form a shell state from a canonical grammar -grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState -grammar2shellState opts (gr,sgr) = - updateShellState opts doParseAll Nothing emptyShellState ((0,sgr,gr,emptyEEnv),[]) --- is 0 safe? - --- | update a shell state from a canonical grammar -updateShellState :: Options -> NoParse -> Maybe Ident -> ShellState -> - ((Int,G.SourceGrammar,CanonGrammar,EEnv),[(String,(FilePath,ModTime))]) -> - Err ShellState -updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do - let cgr0 = M.updateMGrammar (canModules sh) gr - - -- a0 = abstract of old state - -- a1 = abstract of compiled grammar - - let a0 = abstract sh - a1 <- return $ case mcnc of - Just cnc -> err (const Nothing) Just $ M.abstractOfConcrete cgr0 cnc - _ -> M.greatestAbstract cgr0 - - -- abstr0 = a1 if it exists - - let (abstr0,isNew) = case (a0,a1) of - (Just a, Just b) | a /= b -> (a1, True) - (Nothing, Just _) -> (a1, True) - _ -> (a0, False) - - let concrs0 = maybe [] (M.allConcretes cgr0) abstr0 - - let abstrs = nubBy (\ (x,_) (y,_) -> x == y) $ - maybe id (\a -> ((a,concrs0):)) abstr0 $ abstracts sh - - let needed = nub $ concatMap (requiredCanModules (length abstrs == 1) cgr0) (maybe [] singleton abstr0 ++ concrs0) - purge = nubBy (\x y -> fst x == fst y) . filter (\(m,mo) -> elem m needed && not (isIncompleteCanon (m,mo))) - - let cgr = M.MGrammar $ purge $ M.modules cgr0 - - let oldConcrs = map (snd . fst) (concretes sh) - newConcrs = maybe [] (M.allConcretes gr) abstr0 - toRetain (c,v) = notElem c newConcrs - let complete m = case M.lookupModule gr m of - Ok mo -> not $ isIncompleteCanon (m,mo) - _ -> False - - let concrs = filter (\i -> complete i && elem i needed) $ nub $ newConcrs ++ oldConcrs - concr0 = ifNull Nothing (return . head) concrs - notInrts f = notElem f $ map fst rts - subcgr = unSubelimCanon cgr - cf's0 <- if (not (oElem (iOpt "docf") opts) && -- cf only built with -docf - (oElem noCF opts || not (hasHOAS cgr))) -- or HOAS, if not -nocf - then return $ map snd $ cfs sh - else mapM (canon2cf opts ign subcgr) newConcrs - let cf's = zip newConcrs cf's0 ++ filter toRetain (cfs sh) - - let morphs = [(c,mkMorpho subcgr c) | c <- newConcrs] ++ filter toRetain (morphos sh) - let probss = [] ----- - - - let fromGFC = snd . snd . Cnv.convertGFC opts - (mcfgs, cfgs) = unzip $ map (curry fromGFC cgr) concrs - gfcc = canon2gfcc opts cgr ---- UTF8 - fcfgs = [(c,g) | c@(IC cn) <- concrs, Just g <- [lookFCFG gfcc (CId cn)]] - pInfos = zipWith3 Prs.buildPInfo mcfgs (map snd fcfgs) cfgs - - let funs = funRulesOf cgr - let cats = allCatsOf cgr - let csi = [(c,(co, - [(fun,typ) | (fun,typ) <- funs, compatType tc typ], - funsOnTypeFs compatType funs tc)) - | (c,co) <- cats, let tc = cat2val co c] - let deps = True ---- not $ null $ allDepCats cgr - let binds = [] ---- allCatsWithBind cgr - let src = M.updateMGrammar (srcModules sh) sgr - - return $ ShSt { - abstract = abstr0, - concrete = concr0, - concretes = zip (zip concrs concrs) (repeat True), - canModules = cgr, - srcModules = src, - cfs = cf's, - abstracts = maybe [] (\a -> [(a,concrs)]) abstr0, - mcfgs = zip concrs mcfgs, - fcfgs = fcfgs, - cfgs = zip concrs cfgs, - pInfos = zip concrs pInfos, - morphos = morphs, - treebanks = treebanks sh, - probss = zip concrs probss, - gloptions = gloptions sh, --- opts, -- this would be command-line options - readFiles = [ft | ft@(f,(_,_)) <- readFiles sh, notInrts f] ++ rts, - absCats = csi, - statistics = [StDepTypes deps,StBoundVars binds], - transfers = transfers sh, - evalEnv = eenv - } - -prShellStateInfo :: ShellState -> String -prShellStateInfo sh = unlines [ - "main abstract : " +++ abstractName sh, - "main concrete : " +++ maybe "(none)" P.prt (concrete sh), - "actual concretes : " +++ unwords (map (P.prt . fst . fst) (actualConcretes sh)), - "all abstracts : " +++ unwords (map (P.prt . fst) (abstracts sh)), - "all concretes : " +++ unwords (map (P.prt . fst . fst) (concretes sh)), - "canonical modules :" +++ unwords (map (P.prt .fst) (M.modules (canModules sh))), - "source modules : " +++ unwords (map (P.prt .fst) (M.modules (srcModules sh))), - "global options : " +++ prOpts (gloptions sh), - "transfer modules : " +++ unwords (map (P.prt . fst) (transfers sh)), - "treebanks : " +++ unwords (map (P.prt . fst) (treebanks sh)) - ] - -abstractName :: ShellState -> String -abstractName sh = maybe "(none)" P.prt (abstract sh) - --- | throw away those abstracts that are not needed --- could be more aggressive -filterAbstracts :: [Ident] -> CanonGrammar -> CanonGrammar -filterAbstracts absts cgr = M.MGrammar (nubBy (\x y -> fst x == fst y) [m | m <- ms, needed m]) where - ms = M.modules cgr - needed (i,_) = elem i needs - needs = [i | (i,M.ModMod m) <- ms, not (M.isModAbs m) || any (dep i) absts] - dep i a = elem i (ext mse a) - mse = [(i,me) | (i,M.ModMod m) <- ms, M.isModAbs m, me <- [M.extends m]] - ext es a = case lookup a es of - Just e -> a : concatMap (ext es) e ---- FIX multiple exts - _ -> [] - -purgeShellState :: ShellState -> ShellState -purgeShellState sh = ShSt { - abstract = abstr, - concrete = concrete sh, - concretes = concrs, - canModules = M.MGrammar $ filter complete $ purge $ M.modules $ canModules sh, - srcModules = M.emptyMGrammar, - cfs = cfs sh, - abstracts = maybe [] (\a -> [(a,map (snd . fst) concrs)]) abstr, - mcfgs = mcfgs sh, - fcfgs = fcfgs sh, - cfgs = cfgs sh, - pInfos = pInfos sh, - morphos = morphos sh, - treebanks = treebanks sh, - probss = probss sh, - gloptions = gloptions sh, - readFiles = [], - absCats = absCats sh, - statistics = statistics sh, - transfers = transfers sh, - evalEnv = emptyEEnv - } - where - abstr = abstract sh - concrs = [((a,i),b) | ((a,i),b) <- concretes sh, elem i needed] - isSingle = length (abstracts sh) == 1 - needed = nub $ concatMap (requiredCanModules isSingle (canModules sh)) acncs - purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst) - acncs = maybe [] singleton abstr ++ map (snd . fst) (actualConcretes sh) - complete = not . isIncompleteCanon - -changeMain :: Maybe Ident -> ShellState -> Err ShellState -changeMain Nothing (ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) = - return (ShSt Nothing Nothing [] ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) -changeMain - (Just c) st@(ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) = - case lookup c (M.modules ms) of - Just _ -> do - a <- M.abstractOfConcrete ms c - let cas = M.allConcretes ms a - let cs' = [((c,c),True) | c <- cas] - return (ShSt (Just a) (Just c) cs' ms ss cfs old_pis mcfgs fcfgs cfgs - pinfos mos tbs pbs os rs acs s trs ee) - _ -> P.prtBad "The state has no concrete syntax named" c - --- | form just one state grammar, if unique, from a canonical grammar -grammar2stateGrammar :: Options -> CanonGrammar -> Err StateGrammar -grammar2stateGrammar opts gr = do - st <- grammar2shellState opts (gr,M.emptyMGrammar) - concr <- maybeErr "no concrete syntax" $ concrete st - return $ stateGrammarOfLang st concr - -resourceOfShellState :: ShellState -> Maybe Ident -resourceOfShellState = M.greatestResource . srcModules - -qualifTop :: StateGrammar -> G.QIdent -> G.QIdent -qualifTop gr (_,c) = (absId gr,c) - -stateGrammarOfLang :: ShellState -> Language -> StateGrammar -stateGrammarOfLang = stateGrammarOfLangOpt True - -stateGrammarOfLangOpt :: Bool -> ShellState -> Language -> StateGrammar -stateGrammarOfLangOpt purg st0 l = StGr { - absId = err (const (identC "Abs")) id $ M.abstractOfConcrete allCan l, --- - cncId = l, - grammar = allCan, - cf = maybe emptyCF id (lookup l (cfs st)), - mcfg = maybe [] id $ lookup l $ mcfgs st, - fcfg = maybe ([],Map.empty) id $ lookup l $ fcfgs st, - cfg = maybe [] id $ lookup l $ cfgs st, - pInfo = maybe (Prs.buildPInfo [] ([],Map.empty) []) id $ lookup l $ pInfos st, - morpho = maybe emptyMorpho id (lookup l (morphos st)), - probs = maybe emptyProbs id (lookup l (probss st)), - loptions = errVal noOptions $ lookupOptionsCan allCan - } - where - st = (if purg then purgeShellState else id) $ errVal st0 $ changeMain (Just l) st0 - allCan = canModules st - -grammarOfLang :: ShellState -> Language -> CanonGrammar -cfOfLang :: ShellState -> Language -> CF -morphoOfLang :: ShellState -> Language -> Morpho -probsOfLang :: ShellState -> Language -> Probs -optionsOfLang :: ShellState -> Language -> Options - -grammarOfLang st = stateGrammarST . stateGrammarOfLang st -cfOfLang st = stateCF . stateGrammarOfLang st -morphoOfLang st = stateMorpho . stateGrammarOfLang st -probsOfLang st = stateProbs . stateGrammarOfLang st -optionsOfLang st = stateOptions . stateGrammarOfLang st - -removeLang :: Language -> ShellState -> ShellState -removeLang lang st = purgeShellState $ st{concretes = concs1} where - concs1 = filter ((/=lang) . snd . fst) $ concretes st - --- | the last introduced grammar, stored in options, is the default for operations -firstStateGrammar :: ShellState -> StateGrammar -firstStateGrammar st = errVal (stateAbstractGrammar st) $ do - concr <- maybeErr "no concrete syntax" $ concrete st - return $ stateGrammarOfLang st concr - -mkStateGrammar :: ShellState -> Language -> StateGrammar -mkStateGrammar = stateGrammarOfLang - -stateAbstractGrammar :: ShellState -> StateGrammar -stateAbstractGrammar st = StGr { - absId = maybe (identC "Abs") id (abstract st), --- - cncId = identC "#Cnc", --- - grammar = canModules st, ---- only abstarct ones - cf = emptyCF, - mcfg = [], - fcfg = ([],Map.empty), - cfg = [], - pInfo = Prs.buildPInfo [] ([],Map.empty) [], - morpho = emptyMorpho, - probs = emptyProbs, - loptions = gloptions st ---- - } - - --- analysing shell state into parts - -globalOptions :: ShellState -> Options -allLanguages :: ShellState -> [Language] -allTransfers :: ShellState -> [Ident] -allCategories :: ShellState -> [G.Cat] -allStateGrammars :: ShellState -> [StateGrammar] -allStateGrammarsWithNames :: ShellState -> [(Language, StateGrammar)] -allGrammarFileNames :: ShellState -> [String] -allActiveStateGrammarsWithNames :: ShellState -> [(Language, StateGrammar)] -allActiveGrammars :: ShellState -> [StateGrammar] - -globalOptions = gloptions ---allLanguages = map (fst . fst) . concretes -allLanguages = map (snd . fst) . actualConcretes -allTransfers = map fst . transfers -allCategories = map fst . allCatsOf . canModules - -allStateGrammars = map snd . allStateGrammarsWithNames - -allStateGrammarsWithNames st = - [(c, mkStateGrammar st c) | ((c,_),_) <- actualConcretes st] - -allGrammarFileNames st = [prLanguage c ++ ".gf" | ((c,_),_) <- actualConcretes st] - -allActiveStateGrammarsWithNames st = - [(c, mkStateGrammar st c) | ((c,_),True) <- concretes st] --- actual - -allActiveGrammars = map snd . allActiveStateGrammarsWithNames - -pathOfModule :: ShellState -> Ident -> FilePath -pathOfModule sh m = maybe "module not found" fst $ lookup (P.prt m) $ readFiles sh - --- command-line option -lang=foo overrides the actual grammar in state -grammarOfOptState :: Options -> ShellState -> StateGrammar -grammarOfOptState opts st = - maybe (firstStateGrammar st) (stateGrammarOfLang st . language) $ - getOptVal opts useLanguage - -languageOfOptState :: Options -> ShellState -> Maybe Language -languageOfOptState opts st = - maybe (concrete st) (return . language) $ getOptVal opts useLanguage - --- | command-line option -cat=foo overrides the possible start cat of a grammar -firstCatOpts :: Options -> StateGrammar -> CFCat -firstCatOpts opts sgr = - maybe (stateFirstCat sgr) (string2CFCat (P.prt (absId sgr))) $ - getOptVal opts firstCat - --- | the first cat for random generation -firstAbsCat :: Options -> StateGrammar -> G.QIdent -firstAbsCat opts = cfCat2Cat . firstCatOpts opts - --- | Gets the start category for the grammar from the options. --- If the startcat is not set in the options, we look --- for a flag in the grammar. If there is no flag in the --- grammar, S is returned. -startCatStateOpts :: Options -> StateGrammar -> CFCat -startCatStateOpts opts sgr = - string2CFCat a (fromMaybe "S" (optsStartCat `mplus` grStartCat)) - where optsStartCat = getOptVal opts gStartCat - grStartCat = getOptVal (stateOptions sgr) gStartCat - a = P.prt (absId sgr) - --- | a grammar can have start category as option startcat=foo ; default is S -stateFirstCat :: StateGrammar -> CFCat -stateFirstCat = startCatStateOpts noOptions - -stateIsWord :: StateGrammar -> String -> Bool -stateIsWord sg = isKnownWord (stateMorpho sg) - -addProbs :: (Ident,Probs) -> ShellState -> Err ShellState -addProbs ip@(lang,probs) sh = do - let gr = grammarOfLang sh lang - probs' <- checkGrammarProbs gr probs - let pbs' = (lang,probs') : filter ((/= lang) . fst) (probss sh) - return $ sh{probss = pbs'} - -addTransfer :: (Ident,T.Env) -> ShellState -> ShellState -addTransfer it@(i,_) sh = - sh {transfers = it : filter ((/= i) . fst) (transfers sh)} - -addTreebanks :: [(Ident,Treebank)] -> ShellState -> ShellState -addTreebanks its sh = sh {treebanks = its ++ treebanks sh} - -findTreebank :: ShellState -> Ident -> Err Treebank -findTreebank sh i = maybeErr "no treebank found" $ lookup i $ treebanks sh - --- modify state - -type ShellStateOper = ShellState -> ShellState -type ShellStateOperErr = ShellState -> Err ShellState - -reinitShellState :: ShellStateOper -reinitShellState = const emptyShellState - -languageOn, languageOff :: Language -> ShellStateOper -languageOn = languageOnOff True -languageOff = languageOnOff False - -languageOnOff :: Bool -> Language -> ShellStateOper ---- __________ this is OBSOLETE -languageOnOff b lang sh = sh {concretes = cs'} where - cs' = [if lang==l then (lc,b) else i | i@(lc@(l,c),_) <- concretes sh] - -changeOptions :: (Options -> Options) -> ShellStateOper ---- __________ this is OBSOLETE -changeOptions f sh = sh {gloptions = f (gloptions sh)} - -addGlobalOptions :: Options -> ShellStateOper -addGlobalOptions = changeOptions . addOptions - -removeGlobalOptions :: Options -> ShellStateOper -removeGlobalOptions = changeOptions . removeOptions - diff --git a/src-3.0/GF/Compile/Wordlist.hs b/src-3.0/GF/Compile/Wordlist.hs deleted file mode 100644 index 3fbc066bd..000000000 --- a/src-3.0/GF/Compile/Wordlist.hs +++ /dev/null @@ -1,108 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Wordlist --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: --- > CVS $Author: --- > CVS $Revision: --- --- Compile a gfwl file (multilingual word list) to an abstract + concretes ------------------------------------------------------------------------------ - -module GF.Compile.Wordlist (mkWordlist) where - -import GF.Data.Operations -import GF.Infra.UseIO -import Data.List -import Data.Char -import System.FilePath - --- read File.gfwl, write File.gf (abstract) and a set of concretes --- return the names of the concretes - -mkWordlist :: FilePath -> IO [FilePath] -mkWordlist file = do - s <- readFileIf file - let abs = dropExtension file - let (cnchs,wlist) = pWordlist abs $ filter notComment $ lines s - let (gr,grs) = mkGrammars abs cnchs wlist - let cncfs = [cnc ++ ".gf" | (cnc,_) <- cnchs] - mapM_ (uncurry writeFile) $ (abs ++ ".gf",gr) : zip cncfs grs - putStrLn $ "wrote " ++ unwords ((abs ++ ".gf") : cncfs) - return cncfs - -{- --- syntax of files, e.g. - - # Svenska - Franska - Finska -- names of concretes - - berg - montagne - vuori -- word entry - --- this creates: - - cat S ; - fun berg_S : S ; - lin berg_S = {s = ["berg"]} ; - lin berg_S = {s = ["montagne"]} ; - lin berg_S = {s = ["vuori"]} ; - --- support for different categories to be elaborated. The syntax it - - Verb . klättra - grimper / escalader - kiivetä / kiipeillä - --- notice that a word can have several alternative (separator /) --- and that an alternative can consist of several words --} - -type CncHeader = (String,String) -- module name, module header - -type Wordlist = [(String, [[String]])] -- cat, variants for each cnc - - -pWordlist :: String -> [String] -> ([CncHeader],Wordlist) -pWordlist abs ls = (headers,rules) where - (hs,rs) = span ((=="#") . take 1) ls - headers = map mkHeader $ chunks "-" $ filter (/="#") $ words $ concat hs - rules = map (mkRule . words) rs - - mkHeader ws = case ws of - w:ws2 -> (w, unwords ("concrete":w:"of":abs:"=":ws2)) - mkRule ws = case ws of - cat:".":vs -> (cat, mkWords vs) - _ -> ("S", mkWords ws) - mkWords = map (map unwords . chunks "/") . chunks "-" - - -mkGrammars :: String -> [CncHeader] -> Wordlist -> (String,[String]) -mkGrammars ab hs wl = (abs,cncs) where - abs = unlines $ map unwords $ - ["abstract",ab,"=","{"]: - cats ++ - funs ++ - [["}"]] - - cncs = [unlines $ (h ++ " {") : map lin rs ++ ["}"] | ((_,h),rs) <- zip hs rss] - - cats = [["cat",c,";"] | c <- nub $ map fst wl] - funs = [["fun", f , ":", c,";"] | (f,c,_) <- wlf] - - wlf = [(ident f c, c, ws) | (c,ws@(f:_)) <- wl] - - rss = [[(f, wss !! i) | (f,_,wss) <- wlf] | i <- [0..length hs - 1]] - - lin (f,ss) = unwords ["lin", f, "=", "{s", "=", val ss, "}", ";"] - - val ss = case ss of - [w] -> quote w - _ -> "variants {" ++ unwords (intersperse ";" (map quote ss)) ++ "}" - - quote w = "[" ++ prQuotedString w ++ "]" - - ident f c = concat $ intersperse "_" $ words (head f) ++ [c] - - -notComment s = not (all isSpace s) && take 2 s /= "--" - |