diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index b8db1e1a9..9b71c0f39 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -30,7 +30,7 @@ import System.IO import System.Directory import System.FilePath import qualified Data.Map as Map -import qualified Data.Set as Set +--import qualified Data.Set as Set import Data.List(nub) import Data.Maybe (isNothing) import qualified Data.ByteString.Char8 as BS @@ -55,7 +55,7 @@ link opts cnc gr = do let isv = (verbAtLeast opts Normal) putPointE Normal opts "linking ... " $ do let abs = err (const cnc) id $ abstractOfConcrete gr cnc - pgf <- ioeIO (mkCanon2pgf opts gr abs) + pgf <- mkCanon2pgf opts gr abs probs <- ioeIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf) ioeIO $ when (verbAtLeast opts Normal) $ putStrFlush "OK" return $ setProbabilities probs @@ -196,7 +196,7 @@ compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do refreshModule (k,gr) mo3 mo4 <- runPass2 id Optimize "optimizing" $ optimizeModule opts gr mo3r mo5 <- if isModCnc (snd mo4) && flag optPMCFG opts - then runPass2' "generating PMCFG" $ generatePMCFG opts gr mo4 + then runPass2' "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4 else runPass2' "" $ return mo4 generateGFO k' mo5 @@ -215,9 +215,10 @@ compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do putpp s = if null s then id else putPointE Verbose opts (" "++s++" ") idump pass = intermOut opts (Dump pass) . ppModule Internal + -- * Impedance matching runPass = runPass' fst fst snd (ioeErr . runCheck) runPass2 = runPass2e ioeErr - runPass2' = runPass2e ioeIO id Canon + runPass2' = runPass2e id id Canon runPass2e lift f = runPass' id f (const "") lift runPass' ret dump warn lift pass pp m = diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs index 8010f3b15..90686c0bc 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs +++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs @@ -1,7 +1,7 @@ -- | Functions for computing the values of terms in the concrete syntax, in -- | preparation for PMCFG generation. module GF.Compile.Compute.ConcreteNew - (GlobalEnv, resourceValues, normalForm + (GlobalEnv, resourceValues, normalForm, ppL --, Value(..), Env, value2term, eval, apply ) where @@ -148,7 +148,7 @@ value env t0 = T i cs -> valueTable env i cs V ty ts -> do pvs <- paramValues env ty ((VV ty pvs .) . sequence) # mapM (value env) ts - C t1 t2 -> ((vconcat.) # both id) # both (value env) (t1,t2) + C t1 t2 -> ((ok2p vconcat.) # both id) # both (value env) (t1,t2) S t1 t2 -> ((select env.) # both id) # both (value env) (t1,t2) P t l -> --maybe (bug $ "project "++show l++" from "++show v) id $ do ov <- value env t @@ -156,7 +156,7 @@ value env t0 = in maybe (VP v l) id (proj l v) Alts t tts -> (\v vts -> VAlts # v <# mapM (both id) vts) # value env t <# mapM (both (value env)) tts Strs ts -> ((VStrs.) # sequence) # mapM (value env) ts - Glue t1 t2 -> ((glue.) # both id) # both (value env) (t1,t2) + Glue t1 t2 -> ((ok2p glue.) # both id) # both (value env) (t1,t2) ELin c r -> (unlockVRec c.) # value env r EPatt p -> return $ const (VPatt p) -- hmm t -> fail.render $ text "value"<+>ppTerm Unqualified 10 t $$ text (show t) @@ -167,9 +167,7 @@ paramValues env ty = do let ge = global env vconcat vv@(v1,v2) = case vv of - (VError _,_) -> v1 (VString "",_) -> v2 - (_,VError _) -> v2 (_,VString "") -> v1 _ -> VC v1 v2 @@ -190,6 +188,10 @@ ok2 f v1@(VError {}) _ = v1 ok2 f _ v2@(VError {}) = v2 ok2 f v1 v2 = f v1 v2 +ok2p f (v1@VError {},_) = v1 +ok2p f (_,v2@VError {}) = v2 +ok2p f vv = f vv + unlockVRec ::Ident -> Value -> Value unlockVRec c v = case v of @@ -470,9 +472,10 @@ m1 @@ m2 = (m1 =<<) . m2 both f (x,y) = (,) # f x <# f y -ppL (L loc x) = ppLocation "" loc<>text ":"<>ppIdent x +ppL (L loc x) msg = hang (ppLocation "" loc<>colon) 4 + (text "In"<+>ppIdent x<>colon<+>msg) -bugloc loc s = ppbug $ hang (text "In"<+>ppL loc<>text ":") 4 (text s) +bugloc loc s = ppbug $ ppL loc (text s) bug msg = ppbug (text msg) ppbug doc = error $ render $ diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs index 813ee78d4..588b98959 100644 --- a/src/compiler/GF/Compile/Compute/Predef.hs +++ b/src/compiler/GF/Compile/Compute/Predef.hs @@ -109,7 +109,7 @@ delta f vs = [v1,v2] -> toValue `fmap` (f `fmap` fromValue v1 `ap` fromValue v2) _ -> delay - unimpl id = bug $ "unimplemented predefined function: "++showIdent id +-- unimpl id = bug $ "unimplemented predefined function: "++showIdent id -- problem id vs = bug $ "unexpected arguments: Predef."++showIdent id++" "++show vs tk i s = take (max 0 (length s - i)) s :: String diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index dca1f74fd..b6619674c 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -22,8 +22,9 @@ import GF.Grammar.Lookup import GF.Grammar.Predef import GF.Data.BacktrackM import GF.Data.Operations +import GF.Infra.UseIO (IOE) import GF.Data.Utilities (updateNthM, updateNth) -import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues) +import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues,ppL) import System.IO(hPutStr,hPutStrLn,stderr) import qualified Data.Map as Map import qualified Data.Set as Set @@ -38,15 +39,16 @@ import Data.Maybe import Data.Char (isDigit) import Control.Monad import Control.Monad.Identity +import Control.Monad.Trans (liftIO) import Control.Exception ---------------------------------------------------------------------- -- main conversion function -generatePMCFG :: Options -> SourceGrammar -> SourceModule -> IO SourceModule -generatePMCFG opts sgr cmo@(cm,cmi) = do - (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr cenv am cm) Map.empty (jments cmi) - when (verbAtLeast opts Verbose) $ hPutStrLn stderr "" +generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule +generatePMCFG opts sgr opath cmo@(cm,cmi) = do + (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr cenv opath am cm) Map.empty (jments cmi) + when (verbAtLeast opts Verbose) $ liftIO $ hPutStrLn stderr "" return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js}) where cenv = resourceValues gr @@ -65,15 +67,15 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m return (a,(k,y):kys) -addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Ident -> Ident -> SeqSet -> Ident -> Info -> IO (SeqSet, Info) -addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do +addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info) +addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do let pres = protoFCat gr res val pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont] pmcfgEnv0 = emptyPMCFGEnv - b = convert opts gr cenv (L loc id) term val pargs - (seqs1,b1) = addSequencesB seqs b + b <- convert opts gr cenv (floc opath loc id) term val pargs + let (seqs1,b1) = addSequencesB seqs b pmcfgEnv1 = foldBM addRule pmcfgEnv0 (goB b1 CNil []) @@ -86,9 +88,9 @@ addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) !funs_cnt = e-s+1 in (prods_cnt,funs_cnt) - when (verbAtLeast opts Verbose) $ hPutStr stderr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs))) + when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs))) seqs1 `seq` stats `seq` return () - when (verbAtLeast opts Verbose) $ hPutStr stderr (" "++show stats) + when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr (" "++show stats) return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg)) where (ctxt,res,_) = err bug typeForm (lookupFunType gr am id) @@ -99,20 +101,20 @@ addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) newArgs = map getFIds newArgs' in addFunction env0 newCat fun newArgs -addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L loc term)) mprn Nothing) = do +addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L loc term)) mprn Nothing) = do let pres = protoFCat gr (am,id) lincat parg = protoFCat gr (identW,cVar) typeStr pmcfgEnv0 = emptyPMCFGEnv - b = convert opts gr cenv (L loc id) term lincat [parg] - (seqs1,b1) = addSequencesB seqs b + b <- convert opts gr cenv (floc opath loc id) term lincat [parg] + let (seqs1,b1) = addSequencesB seqs b pmcfgEnv1 = foldBM addRule pmcfgEnv0 (goB b1 CNil []) (pres,[parg]) pmcfg = getPMCFG pmcfgEnv1 - when (verbAtLeast opts Verbose) $ hPutStr stderr ("\n+ "++showIdent id++" "++show (catFactor pres)) + when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr ("\n+ "++showIdent id++" "++show (catFactor pres)) seqs1 `seq` pmcfg `seq` return (seqs1,GF.Grammar.CncCat mty mdef mprn (Just pmcfg)) where addRule lins (newCat', newArgs') env0 = @@ -120,12 +122,17 @@ addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) m !fun = mkArray lins in addFunction env0 newCat fun [[fidVar]] -addPMCFG opts gr cenv am cm seqs id info = return (seqs, info) +addPMCFG opts gr cenv opath am cm seqs id info = return (seqs, info) + +floc opath loc id = maybe (L loc id) (\path->L (External path loc) id) opath convert opts gr cenv loc term val pargs = - runCnvMonad gr conv (pargs,[]) + case term' of + Error s -> fail $ render $ ppL loc (text $ "Predef.error: "++s) + _ -> return $ runCnvMonad gr (conv term') (pargs,[]) where - conv = convertTerm opts CNil val =<< unfactor term' + conv t = convertTerm opts CNil val =<< unfactor t + term' = if flag optNewComp opts then normalForm cenv loc (recordExpand val term) -- new evaluator else term -- old evaluator is invoked from GF.Compile.Optimize @@ -152,7 +159,7 @@ unfactor t = CM (\gr c -> c (unfac gr t)) in V ty [restore x v u' | v <- allparams ty] T (TTyped ty) [(PW ,u)] -> let u' = unfac gr u in V ty [u' | _ <- allparams ty] - T (TTyped ty) _ -> -- converTerm doesn't handle these tables + T (TTyped ty) _ -> -- convertTerm doesn't handle these tables ppbug $ sep [text "unfactor"<+>ppTerm Unqualified 10 t, text (show t)] @@ -241,6 +248,7 @@ choices nr path = do (args,_) <- get values -> let path = reversePath rpath in CM (\gr c s -> Case nr path [(value, updateEnv path value gr c s) | (value,index) <- values]) + descend schema path rpath = bug $ "descend "++show (schema,path,rpath) updateEnv path value gr c (args,seq) = case updateNthM (restrictProtoFCat path value) nr args of @@ -271,6 +279,15 @@ data Schema b s c | CTbl Type [(Term, b (Schema b s c))] | CStr s | CPar c +--deriving Show -- doesn't work + +instance Show s => Show (Schema b s c) where + showsPrec _ sch = + case sch of + CRec r -> showString "CRec " . shows (map fst r) + CTbl t _ -> showString "CTbl " . showsPrec 10 t . showString " _" + CStr s -> showString "CStr " . showsPrec 10 s + CPar c -> showString "CPar{}" -- | Path into a term or term schema data Path diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index 6fc572fc9..cc560ca1c 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -22,6 +22,7 @@ import GF.Compile.GeneratePMCFG import GF.Infra.Ident import GF.Infra.Option +import GF.Infra.UseIO (IOE) import GF.Data.Operations import Data.List @@ -35,7 +36,7 @@ import Text.PrettyPrint import Control.Monad.Identity -mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IO D.PGF +mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IOE D.PGF mkCanon2pgf opts gr am = do (an,abs) <- mkAbstr am cncs <- mapM mkConcr (allConcretes gr am) @@ -96,7 +97,7 @@ mkCanon2pgf opts gr am = do -- we have to create the PMCFG code just before linking addMissingPMCFGs seqs [] = return (seqs,[]) addMissingPMCFGs seqs (((m,id), info):is) = do - (seqs,info) <- addPMCFG opts gr cenv am cm seqs id info + (seqs,info) <- addPMCFG opts gr cenv Nothing am cm seqs id info (seqs,is ) <- addMissingPMCFGs seqs is return (seqs, ((m,id), info) : is) diff --git a/src/compiler/GF/Infra/UseIO.hs b/src/compiler/GF/Infra/UseIO.hs index 756df0679..2fdc42d83 100644 --- a/src/compiler/GF/Infra/UseIO.hs +++ b/src/compiler/GF/Infra/UseIO.hs @@ -32,6 +32,7 @@ import System.CPUTime import System.Cmd import Text.Printf import Control.Monad +import Control.Monad.Trans(MonadIO(..)) import Control.Exception(evaluate) import qualified Data.ByteString.Char8 as BS @@ -126,10 +127,7 @@ putStrLnFlush s = putStrLn s >> hFlush stdout -- * IO monad with error; adapted from state monad -newtype IOE a = IOE (IO (Err a)) - -appIOE :: IOE a -> IO (Err a) -appIOE (IOE iea) = iea +newtype IOE a = IOE { appIOE :: IO (Err a) } ioe :: IO (Err a) -> IOE a ioe = IOE @@ -140,6 +138,9 @@ ioeIO io = ioe (io >>= return . return) ioeErr :: Err a -> IOE a ioeErr = ioe . return +ioeErrIn :: String -> IOE a -> IOE a +ioeErrIn msg (IOE ioe) = IOE (fmap (errIn msg) ioe) + instance Functor IOE where fmap = liftM instance Monad IOE where @@ -149,6 +150,8 @@ instance Monad IOE where appIOE $ err ioeBad f x -- f :: a -> IOE a fail = ioeBad +instance MonadIO IOE where liftIO = ioeIO + ioeBad :: String -> IOE a ioeBad = ioe . return . Bad