diff --git a/src/compiler/GF/Command/SourceCommands.hs b/src/compiler/GF/Command/SourceCommands.hs index 949778aad..9d3c5a8dc 100644 --- a/src/compiler/GF/Command/SourceCommands.hs +++ b/src/compiler/GF/Command/SourceCommands.hs @@ -8,9 +8,11 @@ import qualified Data.Map as Map import GF.Infra.SIO(MonadSIO(..),restricted) import GF.Infra.Option(modifyFlags,optTrace) --,noOptions -import GF.Data.Operations (chunks,err,raise) -import GF.Text.Pretty(render) +import GF.Infra.Dependencies(depGraph) +import GF.Infra.CheckM +import GF.Text.Pretty(render,pp) import GF.Data.Str(sstr) +import GF.Data.Operations (chunks,err,raise) import GF.Grammar hiding (Ident,isPrefixOf) import GF.Grammar.Analyse @@ -20,8 +22,6 @@ import GF.Grammar.Lookup (allOpers,allOpersTo) import GF.Compile.Rename(renameSourceTerm) import GF.Compile.Compute.Concrete(normalForm) import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType) -import GF.Infra.Dependencies(depGraph) -import GF.Infra.CheckM(runCheck) import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts) import GF.Command.CommandInfo @@ -162,12 +162,11 @@ sourceCommands = Map.fromList [ do sgr <- getGrammar liftSIO (exec opts (toStrings ts) sgr) - compute_concrete opts ws sgr = + compute_concrete opts ws sgr = fmap fst $ runCheck $ case runP pExp (UTF8.fromString s) of Left (_,msg) -> return $ pipeMessage msg - Right t -> return $ err pipeMessage - (fromString . showTerm sgr style q) - $ checkComputeTerm opts sgr t + Right t -> do t <- checkComputeTerm opts sgr t + return (fromString (showTerm sgr style q t)) where (style,q) = pOpts TermPrintDefault Qualified opts s = unwords ws @@ -200,16 +199,16 @@ sourceCommands = Map.fromList [ | otherwise = unwords $ map prTerm ops return $ fromString printed - show_operations os ts sgr = + show_operations os ts sgr = fmap fst $ runCheck $ case greatestResource sgr of - Nothing -> return $ fromString "no source grammar in scope; did you import with -retain?" + Nothing -> checkError (pp "no source grammar in scope; did you import with -retain?") Just mo -> do let greps = map valueString (listFlags "grep" os) let isRaw = isOpt "raw" os ops <- case ts of _:_ -> do let Right t = runP pExp (UTF8.fromString (unwords ts)) - ty <- err error return $ checkComputeTerm os sgr t + ty <- checkComputeTerm os sgr t return $ allOpersTo sgr ty _ -> return $ allOpers sgr let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops] @@ -254,14 +253,12 @@ sourceCommands = Map.fromList [ return void checkComputeTerm os sgr t = - do mo <- maybe (raise "no source grammar in scope") return $ + do mo <- maybe (checkError (pp "no source grammar in scope")) return $ greatestResource sgr - ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t - inferLType sgr [] t + t <- renameSourceTerm sgr mo t + (t,_) <- inferLType sgr [] t let opts = modifyFlags (\fs->fs{optTrace=isOpt "trace" os}) - t1 = normalForm sgr (L NoLoc identW) t - t2 = evalStr t1 - checkPredefError t2 + fmap evalStr (normalForm sgr (L NoLoc identW) t) where -- ** Try to compute pre{...} tokens in token sequences evalStr t = diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 91990ba28..30ced069d 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -27,7 +27,7 @@ import GF.Infra.Ident import GF.Infra.Option import GF.Compile.TypeCheck.Abstract -import GF.Compile.TypeCheck.Concrete(computeLType,checkLType,inferLType,ppType) +import GF.Compile.TypeCheck.Concrete(checkLType,inferLType,ppType) import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType) import qualified GF.Compile.Compute.Concrete as CN(normalForm) @@ -120,7 +120,7 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc return js _ -> do case mb_def of - Ok def -> do (cont,val) <- linTypeOfType gr cm ty + Ok def -> do (cont,val) <- linTypeOfType gr cm (L loc ty) let linty = (snd (valCat ty),cont,val) return $ Map.insert c (CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js Bad _ -> do noLinOf c @@ -140,8 +140,8 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc checkCnc js (c,info) = case info of CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of - Ok (_,AbsFun (Just (L _ ty)) _ _ _) -> - do (cont,val) <- linTypeOfType gr cm ty + Ok (_,AbsFun (Just (L loc ty)) _ _ _) -> + do (cont,val) <- linTypeOfType gr cm (L loc ty) let linty = (snd (valCat ty),cont,val) return $ Map.insert c (CncFun (Just linty) d mn mf) js _ -> do checkWarn ("function" <+> c <+> "is not in abstract") @@ -181,14 +181,10 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do CncCat mty mdef mref mpr mpmcfg -> do mty <- case mty of - Just (L loc typ) -> chIn loc "linearization type of" $ - (if False --flag optNewComp opts - then do (typ,_) <- CN.checkLType gr typ typeType - typ <- computeLType gr [] typ - return (Just (L loc typ)) - else do (typ,_) <- checkLType gr [] typ typeType - typ <- computeLType gr [] typ - return (Just (L loc typ))) + Just (L loc typ) -> chIn loc "linearization type of" $ do + (typ,_) <- checkLType gr [] typ typeType + typ <- CN.normalForm gr (L loc c) typ + return (Just (L loc typ)) Nothing -> return Nothing mdef <- case (mty,mdef) of (Just (L _ typ),Just (L loc def)) -> @@ -228,20 +224,15 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do ResOper pty pde -> do (pty', pde') <- case (pty,pde) of (Just (L loct ty), Just (L locd de)) -> do - ty' <- chIn loct "operation" $ - (if False --flag optNewComp opts - then CN.checkLType gr ty typeType >>= return . CN.normalForm gr (L loct c) . fst -- !! - else checkLType gr [] ty typeType >>= computeLType gr [] . fst) + ty' <- chIn loct "operation" $ do + (ty,_) <- checkLType gr [] ty typeType + CN.normalForm gr (L loct c) ty (de',_) <- chIn locd "operation" $ - (if False -- flag optNewComp opts - then CN.checkLType gr de ty' - else checkLType gr [] de ty') + checkLType gr [] de ty' return (Just (L loct ty'), Just (L locd de')) (Nothing , Just (L locd de)) -> do (de',ty') <- chIn locd "operation" $ - (if False -- flag optNewComp opts - then CN.inferLType gr de - else inferLType gr [] de) + inferLType gr [] de return (Just (L locd ty'), Just (L locd de')) (Just (L loct ty), Nothing) -> do chIn loct "operation" $ @@ -306,8 +297,8 @@ checkReservedId x = -- auxiliaries -- | linearization types and defaults -linTypeOfType :: Grammar -> ModuleName -> Type -> Check (Context,Type) -linTypeOfType cnc m typ = do +linTypeOfType :: Grammar -> ModuleName -> L Type -> Check (Context,Type) +linTypeOfType cnc m (L loc typ) = do let (cont,cat) = typeSkeleton typ val <- lookLin cat args <- mapM mkLinArg (zip [0..] cont) @@ -325,6 +316,6 @@ linTypeOfType cnc m typ = do plusRecType vars val return (Explicit,symb,rec) lookLin (_,c) = checks [ --- rather: update with defLinType ? - lookupLincat cnc m c >>= computeLType cnc [] + lookupLincat cnc m c >>= CN.normalForm cnc (L loc c) ,return defLinType ] diff --git a/src/compiler/GF/Compile/Compute/Concrete.hs b/src/compiler/GF/Compile/Compute/Concrete.hs index b6870adc2..6edddaf14 100644 --- a/src/compiler/GF/Compile/Compute/Concrete.hs +++ b/src/compiler/GF/Compile/Compute/Concrete.hs @@ -16,6 +16,7 @@ import GF.Grammar.Printer import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok) import GF.Data.Operations(Err(..),err,errIn,maybeErr,mapPairsM) import GF.Data.Utilities(mapFst,mapSnd) +import GF.Infra.CheckM import GF.Infra.Option import Data.STRef import Data.Maybe(fromMaybe) @@ -30,12 +31,12 @@ import GF.Text.Pretty -- * Main entry points -normalForm :: Grammar -> L Ident -> Term -> Term +normalForm :: Grammar -> L Ident -> Term -> Check Term normalForm gr loc t = - case runEvalM gr (eval [] t [] >>= value2term 0) of - Left msg -> error (render (ppL loc msg)) - Right [t] -> t - Right ts -> FV ts + fmap mkFV (runEvalM gr (eval [] t [] >>= value2term 0)) + where + mkFV [t] = t + mkFV ts = FV ts data ThunkState s @@ -52,7 +53,7 @@ data Value s | VSusp (Thunk s) (Env s) [Thunk s] (Thunk s -> EvalM s (Value s)) | VGen {-# UNPACK #-} !Int [Thunk s] | VClosure (Env s) Term - | VProd BindType Ident (Value s) (Value s) + | VProd BindType Ident (Value s) (Env s) Term | VRecType [(Label, Value s)] | VR [(Label, Thunk s)] | VP (Value s) Label [Thunk s] @@ -85,7 +86,7 @@ eval env (Meta i) vs = do tnk <- newMeta i return (VMeta tnk env vs) eval env (ImplArg t) [] = eval env t [] eval env (Prod b x t1 t2)[] = do v1 <- eval env t1 [] - return (VProd b x v1 (VClosure env (Abs b x t2))) + return (VProd b x v1 env t2) eval env (Typed t ty) vs = eval env t vs eval env (RecType lbls) [] = do lbls <- mapM (\(lbl,ty) -> fmap ((,) lbl) (eval env ty [])) lbls return (VRecType lbls) @@ -137,7 +138,6 @@ eval env (EPatt min max p) [] = return (VPatt min max p) eval env (EPattType t) [] = do v <- eval env t [] return (VPattType v) eval env (FV ts) vs = msum [eval env t vs | t <- ts] -eval env (Error msg) vs = fail msg eval env t vs = evalError ("Cannot reduce term" <+> pp t) apply v [] = return v @@ -289,9 +289,11 @@ value2term i (VClosure env (Abs b x t)) = do v <- eval ((x,tnk):env) t [] t <- value2term (i+1) v return (Abs b (identS ('v':show i)) t) -value2term i (VProd b x v1 v2) = do +value2term i (VProd b x v1 env t2) = do t1 <- value2term i v1 - t2 <- value2term i v2 + tnk <- newGen i + v2 <- eval ((x,tnk):env) t2 [] + t2 <- value2term (i+1) v2 return (Prod b x t1 t2) value2term i (VRecType lbls) = do lbls <- mapM (\(lbl,v) -> fmap ((,) lbl) (value2term i v)) lbls @@ -342,7 +344,7 @@ value2int _ = Nothing -- * Evaluation monad type MetaThunks s = Map.Map MetaId (Thunk s) -type Cont s r = MetaThunks s -> r -> ST s (Either Doc r) +type Cont s r = MetaThunks s -> r -> ST s (CheckResult r) newtype EvalM s a = EvalM (forall r . Grammar -> (a -> Cont s r) -> Cont s r) instance Functor (EvalM s) where @@ -361,33 +363,33 @@ instance Monad (EvalM s) where #endif instance Fail.MonadFail (EvalM s) where - fail msg = EvalM (\gr k _ r -> return (Left (pp msg))) + fail msg = EvalM (\gr k _ r -> return (Fail (pp msg))) instance Alternative (EvalM s) where - empty = EvalM (\gr k _ r -> return (Right r)) + empty = EvalM (\gr k _ r -> return (Success r)) (EvalM f) <|> (EvalM g) = EvalM $ \gr k mt r -> do res <- f gr k mt r case res of - Left msg -> return (Left msg) - Right r -> g gr k mt r + Fail msg -> return (Fail msg) + Success r -> g gr k mt r instance MonadPlus (EvalM s) where -runEvalM :: Grammar -> (forall s . EvalM s a) -> Either Doc [a] +runEvalM :: Grammar -> (forall s . EvalM s a) -> Check [a] runEvalM gr f = case runST (case f of - EvalM f -> f gr (\x mt xs -> return (Right (x:xs))) Map.empty []) of - Left msg -> Left msg - Right xs -> Right (reverse xs) + EvalM f -> f gr (\x mt xs -> return (Success (x:xs))) Map.empty []) of + Fail msg -> checkError msg + Success xs -> return (reverse xs) evalError :: Doc -> EvalM s a -evalError msg = EvalM (\gr k _ r -> return (Left msg)) +evalError msg = EvalM (\gr k _ r -> return (Fail msg)) lookupGlobal :: QIdent -> EvalM s Term lookupGlobal q = EvalM $ \gr k mt r -> do case lookupResDef gr q of Ok t -> k t mt r - Bad msg -> return (Left (pp msg)) + Bad msg -> return (Fail (pp msg)) newThunk env t = EvalM $ \gr k mt r -> do tnk <- newSTRef (Unevaluated env t) diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs index 3df28492f..849c9d9a1 100644 --- a/src/compiler/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs @@ -18,13 +18,13 @@ import Debug.Trace(trace) -- | Generate Haskell code for the all concrete syntaxes associated with -- the named abstract syntax in given the grammar. -concretes2haskell opts absname gr = - [(filename,render80 $ concrete2haskell opts abstr cncmod) - | let Grammar abstr cncs = grammar2canonical opts absname gr, - cncmod<-cncs, - let ModId name = concName cncmod - filename = showRawIdent name ++ ".hs" :: FilePath - ] +concretes2haskell opts absname gr = do + Grammar abstr cncs <- grammar2canonical opts absname gr + return [(filename,render80 $ concrete2haskell opts abstr cncmod) + | cncmod<-cncs, + let ModId name = concName cncmod + filename = showRawIdent name ++ ".hs" :: FilePath + ] -- | Generate Haskell code for the given concrete module. -- The only options that make a difference are diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 07e6fc3ff..70d135387 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -148,10 +148,9 @@ addPMCFG opts gr 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 loc term ty@(_,val) pargs = - case normalForm gr loc (etaExpand ty term) of - Error s -> fail $ render $ ppL loc ("Predef.error: "++s) - term -> return $ runCnvMonad gr (convertTerm opts CNil val term) (pargs,[]) +convert opts gr loc term ty@(_,val) pargs = error "TODO: convert" +{- case normalForm gr loc (etaExpand ty term) of + term -> return $ runCnvMonad gr (convertTerm opts CNil val term) (pargs,[])-} where etaExpand (context,val) = mkAbs pars . flip mkApp args where pars = [(Explicit,v) | v <- vars] diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index aedbf22d1..1c11ce31a 100644 --- a/src/compiler/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -18,6 +18,7 @@ import GF.Grammar.Predef(cPredef,cInts) -- import GF.Compile.Compute.Value(Predefined(..)) import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent) import GF.Infra.Option(Options,optionsPGF) +import GF.Infra.CheckM import PGF2(Literal(..)) import GF.Compile.Compute.Concrete(normalForm) import GF.Grammar.Canonical as C @@ -27,15 +28,16 @@ import qualified Debug.Trace as T -- | Generate Canonical code for the named abstract syntax and all associated -- concrete syntaxes -grammar2canonical :: Options -> ModuleName -> G.Grammar -> C.Grammar -grammar2canonical opts absname gr = - Grammar (abstract2canonical absname gr) - (map snd (concretes2canonical opts absname gr)) +grammar2canonical :: Options -> ModuleName -> G.Grammar -> Check C.Grammar +grammar2canonical opts absname gr = do + abs <- abstract2canonical absname gr + cncs <- concretes2canonical opts absname gr + return (Grammar abs (map snd cncs)) -- | Generate Canonical code for the named abstract syntax -abstract2canonical :: ModuleName -> G.Grammar -> Abstract +abstract2canonical :: ModuleName -> G.Grammar -> Check Abstract abstract2canonical absname gr = - Abstract (modId absname) (convFlags gr absname) cats funs + return (Abstract (modId absname) (convFlags gr absname) cats funs) where cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs] @@ -48,7 +50,7 @@ abstract2canonical absname gr = convHypo (bt,name,t) = case typeForm t of ([],(_,cat),[]) -> gId cat -- !! - tf -> error $ "abstract2canonical convHypo: " ++ show tf + tf -> error ("abstract2canonical convHypo: " ++ show tf) convType t = case typeForm t of @@ -61,26 +63,24 @@ abstract2canonical absname gr = -- | Generate Canonical code for the all concrete syntaxes associated with -- the named abstract syntax in given the grammar. -concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)] +concretes2canonical :: Options -> ModuleName -> G.Grammar -> Check [(FilePath, Concrete)] concretes2canonical opts absname gr = - [(cncname,concrete2canonical gr absname cnc cncmod) - | cnc<-allConcretes gr absname, - let cncname = "canonical" render cnc <.> "gf" - Ok cncmod = lookupModule gr cnc - ] + sequence + [fmap ((,) cncname) (concrete2canonical gr absname cnc cncmod) + | cnc<-allConcretes gr absname, + let cncname = "canonical" render cnc <.> "gf" + Ok cncmod = lookupModule gr cnc + ] -- | Generate Canonical GF for the given concrete module. -concrete2canonical :: G.Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Concrete -concrete2canonical gr absname cnc modinfo = - Concrete (modId cnc) (modId absname) (convFlags gr cnc) - (neededParamTypes S.empty (params defs)) - [lincat | (_,Left lincat) <- defs] - [lin | (_,Right lin) <- defs] +concrete2canonical :: G.Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check Concrete +concrete2canonical gr absname cnc modinfo = do + defs <- fmap concat $ mapM (toCanonical gr absname) (M.toList (jments modinfo)) + return (Concrete (modId cnc) (modId absname) (convFlags gr cnc) + (neededParamTypes S.empty (params defs)) + [lincat | (_,Left lincat) <- defs] + [lin | (_,Right lin) <- defs]) where - defs = concatMap (toCanonical gr absname) . - M.toList $ - jments modinfo - params = S.toList . S.unions . map fst neededParamTypes have [] = [] @@ -93,29 +93,22 @@ concrete2canonical gr absname cnc modinfo = -- toCanonical :: G.Grammar -> ModuleName -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)] toCanonical gr absname (name,jment) = case jment of - CncCat (Just (L loc typ)) _ _ pprn _ -> - [(pts,Left (LincatDef (gId name) (convType ntyp)))] - where - pts = paramTypes gr ntyp - ntyp = nf loc typ - CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ -> - [(tts,Right (LinDef (gId name) (map gId args) (convert gr e')))] - where - tts = tableTypes gr [e'] - - e' = cleanupRecordFields lincat $ - unAbs (length params) $ - nf loc (mkAbs params (mkApp def (map Vr args))) - params = [(b,x)|(b,x,_)<-ctx] - args = map snd params - + CncCat (Just (L loc typ)) _ _ pprn _ -> do + ntyp <- normalForm gr (L loc name) typ + let pts = paramTypes gr ntyp + return [(pts,Left (LincatDef (gId name) (convType ntyp)))] + CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ -> do + let params = [(b,x)|(b,x,_)<-ctx] + args = map snd params + e0 <- normalForm gr (L loc name) (mkAbs params (mkApp def (map Vr args))) + let e = cleanupRecordFields lincat (unAbs (length params) e0) + tts = tableTypes gr [e] + return [(tts,Right (LinDef (gId name) (map gId args) (convert gr e)))] AnyInd _ m -> case lookupOrigInfo gr (m,name) of Ok (m,jment) -> toCanonical gr absname (name,jment) - _ -> [] - _ -> [] + _ -> return [] + _ -> return [] where - nf loc = normalForm gr (L loc name) - unAbs 0 t = t unAbs n (Abs _ _ t) = unAbs (n-1) t unAbs _ t = t diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs index ad2ff9d6c..c78c16819 100644 --- a/src/compiler/GF/Compile/Optimize.hs +++ b/src/compiler/GF/Compile/Optimize.hs @@ -15,15 +15,16 @@ module GF.Compile.Optimize (optimizeModule) where -import GF.Grammar.Grammar import GF.Infra.Ident +import GF.Infra.CheckM +import GF.Infra.Option +import GF.Grammar.Grammar import GF.Grammar.Printer import GF.Grammar.Macros import GF.Grammar.Lookup import GF.Grammar.Predef import GF.Compile.Compute.Concrete(normalForm) import GF.Data.Operations -import GF.Infra.Option import Control.Monad import qualified Data.Set as Set @@ -33,7 +34,7 @@ import Debug.Trace -- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005. -optimizeModule :: Options -> SourceGrammar -> SourceModule -> Err SourceModule +optimizeModule :: Options -> SourceGrammar -> SourceModule -> Check SourceModule optimizeModule opts sgr m@(name,mi) | mstatus mi == MSComplete = do ids <- topoSortJments m @@ -47,7 +48,7 @@ optimizeModule opts sgr m@(name,mi) info <- evalInfo oopts sgr (name,mi) i info return (mi{jments=Map.insert i info (jments mi)}) -evalInfo :: Options -> SourceGrammar -> SourceModule -> Ident -> Info -> Err Info +evalInfo :: Options -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info evalInfo opts sgr m c info = do (if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return () @@ -75,7 +76,9 @@ evalInfo opts sgr m c info = do return (Just (L loc (factor param c 0 re))) _ -> return pre -- indirection - let ppr' = fmap (evalPrintname sgr c) ppr + ppr' <- case ppr of + Just pr -> fmap Just (evalPrintname sgr c pr) + Nothing -> return ppr return (CncCat ptyp pde' pre' ppr' mpmcfg) @@ -85,7 +88,9 @@ evalInfo opts sgr m c info = do Just (L loc de) -> do de <- partEval opts gr (cont,val) de return (Just (L loc (factor param c 0 de))) Nothing -> return pde - let ppr' = fmap (evalPrintname sgr c) ppr + ppr' <- case ppr of + Just pr -> fmap Just (evalPrintname sgr c pr) + Nothing -> return ppr return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed {- ResOper pty pde @@ -106,15 +111,16 @@ evalInfo opts sgr m c info = do eIn cat = errIn (render ("Error optimizing" <+> cat <+> c <+> ':')) -- | the main function for compiling linearizations -partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term -partEval opts = {-if flag optNewComp opts - then-} partEvalNew opts +partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Check Term +partEval opts = error "TODO: partEval" + {-if flag optNewComp opts + then partEvalNew opts-} {-else partEvalOld opts-} - +{- partEvalNew opts gr (context, val) trm = errIn (render ("partial evaluation" <+> ppTerm Qualified 0 trm)) $ checkPredefError trm -{- + partEvalOld opts gr (context, val) trm = errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $ do let vars = map (\(bt,x,t) -> x) context args = map Vr vars @@ -148,7 +154,7 @@ recordExpand typ trm = case typ of -} -- | auxiliaries for compiling the resource -mkLinDefault :: SourceGrammar -> Type -> Err Term +mkLinDefault :: SourceGrammar -> Type -> Check Term mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ where mkDefField typ = case typ of @@ -157,23 +163,22 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ let T _ cs = mkWildCases t' return $ T (TWild p) cs Sort s | s == cStr -> return $ Vr varStr - QC p -> do vs <- lookupParamValues gr p - case vs of - v:_ -> return v - _ -> Bad (render ("no parameter values given to type" <+> ppQIdent Qualified p)) + QC p -> do case lookupParamValues gr p of + Ok (v:_) -> return v + _ -> checkError ("no parameter values given to type" <+> ppQIdent Qualified p) RecType r -> do let (ls,ts) = unzip r ts <- mapM mkDefField ts return $ R (zipWith assign ls ts) _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val - _ -> Bad (render ("linearization type field cannot be" <+> typ)) + _ -> checkError ("linearization type field cannot be" <+> typ) -mkLinReference :: SourceGrammar -> Type -> Err Term +mkLinReference :: SourceGrammar -> Type -> Check Term mkLinReference gr typ = liftM (Abs Explicit varStr) $ case mkDefField typ (Vr varStr) of Bad "no string" -> return Empty - x -> x + Ok x -> return x where mkDefField ty trm = case ty of @@ -190,8 +195,10 @@ mkLinReference gr typ = _ | Just _ <- isTypeInts typ -> Bad "no string" _ -> Bad (render ("linearization type field cannot be" <+> typ)) -evalPrintname :: Grammar -> Ident -> L Term -> L Term -evalPrintname gr c (L loc pr) = L loc (normalForm gr (L loc c) pr) +evalPrintname :: Grammar -> Ident -> L Term -> Check (L Term) +evalPrintname gr c (L loc pr) = do + pr <- normalForm gr (L loc c) pr + return (L loc pr) -- do even more: factor parametric branches diff --git a/src/compiler/GF/CompileOne.hs b/src/compiler/GF/CompileOne.hs index 48761671a..9d0814328 100644 --- a/src/compiler/GF/CompileOne.hs +++ b/src/compiler/GF/CompileOne.hs @@ -107,7 +107,7 @@ compileSourceModule opts cwd mb_gfFile gr = -- Apply to complete modules when not generating tags backend mo3 = - do mo4 <- runPassE Optimize "optimizing" $ optimizeModule opts gr mo3 + do mo4 <- runPass Optimize "optimizing" $ optimizeModule opts gr mo3 if isModCnc (snd mo4) && flag optPMCFG opts then runPassI "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4 else runPassI "" $ return mo4 @@ -128,7 +128,6 @@ compileSourceModule opts cwd mb_gfFile gr = -- * Running a compiler pass, with impedance matching runPass = runPass' fst fst snd (liftErr . runCheck' opts) - runPassE = runPass2e liftErr id runPassI = runPass2e id id Canon runPass2e lift dump = runPass' id dump (const "") lift diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs index b5c7edec3..cfad55941 100644 --- a/src/compiler/GF/Compiler.hs +++ b/src/compiler/GF/Compiler.hs @@ -15,6 +15,7 @@ import GF.Grammar.CFG --import GF.Infra.Ident(showIdent) import GF.Infra.UseIO import GF.Infra.Option +import GF.Infra.CheckM import GF.Data.ErrM import GF.System.Directory import GF.Text.Pretty(render,render80) @@ -67,22 +68,25 @@ compileSourceFiles opts fs = where ofmts = flag optOutputFormats opts - cnc2haskell (cnc,gr) = - do mapM_ writeExport $ concretes2haskell opts (srcAbsName gr cnc) gr + cnc2haskell (cnc,gr) = do + (res,_) <- runCheck (concretes2haskell opts (srcAbsName gr cnc) gr) + mapM_ writeExport res - abs2canonical (cnc,gr) = - writeExport ("canonical/"++render absname++".gf",render80 canAbs) + abs2canonical (cnc,gr) = do + (canAbs,_) <- runCheck (abstract2canonical absname gr) + writeExport ("canonical/"++render absname++".gf",render80 canAbs) where absname = srcAbsName gr cnc - canAbs = abstract2canonical absname gr - cnc2canonical (cnc,gr) = - mapM_ (writeExport.fmap render80) $ - concretes2canonical opts (srcAbsName gr cnc) gr + cnc2canonical (cnc,gr) = do + (res,_) <- runCheck (concretes2canonical opts (srcAbsName gr cnc) gr) + mapM_ (writeExport.fmap render80) res - grammar2json (cnc,gr) = encodeJSON (render absname ++ ".json") gr_canon - where absname = srcAbsName gr cnc - gr_canon = grammar2canonical opts absname gr + grammar2json (cnc,gr) = do + (gr_canon,_) <- runCheck (grammar2canonical opts absname gr) + return (encodeJSON (render absname ++ ".json") gr_canon) + where + absname = srcAbsName gr cnc writeExport (path,s) = writing opts path $ writeUTF8File path s diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs index 0cff7384a..9b61d9dfe 100644 --- a/src/compiler/GF/Grammar/Binary.hs +++ b/src/compiler/GF/Grammar/Binary.hs @@ -189,7 +189,6 @@ instance Binary Term where put (FV x) = putWord8 32 >> put x put (Alts x y) = putWord8 33 >> put (x,y) put (Strs x) = putWord8 34 >> put x - put (Error x) = putWord8 35 >> put x get = do tag <- getWord8 case tag of @@ -228,7 +227,6 @@ instance Binary Term where 32 -> get >>= \x -> return (FV x) 33 -> get >>= \(x,y) -> return (Alts x y) 34 -> get >>= \x -> return (Strs x) - 35 -> get >>= \x -> return (Error x) _ -> decodingError instance Binary Patt where diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index cbd5f0a5b..a7267ddc4 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -398,7 +398,6 @@ data Term = | Alts Term [(Term, Term)] -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@ | Strs [Term] -- ^ conditioning prefix strings: @strs {s ; ...}@ - | Error String -- ^ error values returned by Predef.error deriving (Show, Eq, Ord) -- | Patterns diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index bad091c55..4501b2f3b 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -238,12 +238,6 @@ isPredefConstant t = case t of Q (mod,_) | mod == cPredef || mod == cPredefAbs -> True _ -> False -checkPredefError :: Fail.MonadFail m => Term -> m Term -checkPredefError t = - case t of - Error s -> fail ("Error: "++s) - _ -> return t - cnPredef :: Ident -> Term cnPredef f = Q (cPredef,f) diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index 18a68dab9..48b05a188 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -240,7 +240,6 @@ ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>' ppTerm q d (ImplArg e) = braces (ppTerm q 0 e) ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t) ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t) -ppTerm q d (Error s) = prec d 4 ("Predef.error" <+> str s) ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs index b336fa6be..5fa8365af 100644 --- a/src/compiler/GF/Infra/CheckM.hs +++ b/src/compiler/GF/Infra/CheckM.hs @@ -13,7 +13,7 @@ ----------------------------------------------------------------------------- module GF.Infra.CheckM - (Check, CheckResult, Message, runCheck, runCheck', + (Check, CheckResult(..), Message, runCheck, runCheck', checkError, checkCond, checkWarn, checkWarnings, checkAccumError, checkIn, checkInModule, checkMap, checkMapRecover, parallelCheck, accumulateError, commitCheck, diff --git a/src/compiler/GF/Infra/SIO.hs b/src/compiler/GF/Infra/SIO.hs index 11b8b850a..1c1829428 100644 --- a/src/compiler/GF/Infra/SIO.hs +++ b/src/compiler/GF/Infra/SIO.hs @@ -24,12 +24,14 @@ import Control.Applicative(Applicative(..)) import Control.Monad(liftM,ap) import Control.Monad.Trans(MonadTrans(..)) import System.IO(hPutStr,hFlush,stdout) +import System.IO.Error(isUserError,ioeGetErrorString) import GF.System.Catch(try) import System.Process(system) import System.Environment(getEnv) import Control.Concurrent.Chan(newChan,writeChan,getChanContents) import GF.Infra.Concurrency(lazyIO) import GF.Infra.UseIO(Output(..)) +import GF.Data.Operations(ErrorMonad(..)) import qualified System.CPUTime as IO(getCPUTime) import qualified System.Directory as IO(getCurrentDirectory) import qualified System.Random as IO(newStdGen) @@ -37,6 +39,7 @@ import qualified GF.Infra.UseIO as IO(getLibraryDirectory) import qualified GF.System.Signal as IO(runInterruptibly) import qualified GF.Command.Importing as GF(importGrammar, importSource) import qualified Control.Monad.Fail as Fail +import Control.Exception -- * The SIO monad @@ -62,6 +65,14 @@ instance Output SIO where putStrLnE = putStrLnFlush putStrE = putStr +instance ErrorMonad SIO where + raise = fail + handle m h = SIO $ \putStr -> + catch (unS m putStr) $ + \e -> if isUserError e + then unS (h (ioeGetErrorString e)) putStr + else ioError e + class {- Monad m => -} MonadSIO m where liftSIO :: SIO a -> m a -- ^ If the Monad m superclass is included, then the generic instance -- for monad transformers below would require UndecidableInstances @@ -96,7 +107,7 @@ restricted io = SIO (const (restrictedIO io)) restrictedSystem = restricted . system restrictedIO io = - either (const io) (const $ fail message) =<< try (getEnv "GF_RESTRICTED") + either (const io) (const $ fail message) =<< GF.System.Catch.try (getEnv "GF_RESTRICTED") where message = "This operation is not allowed when GF is running in restricted mode." diff --git a/testsuite/compiler/compute/predef.gfs.gold b/testsuite/compiler/compute/predef.gfs.gold index 0db3b26d5..275df82bf 100644 --- a/testsuite/compiler/compute/predef.gfs.gold +++ b/testsuite/compiler/compute/predef.gfs.gold @@ -23,9 +23,7 @@ Predef.PTrue Predef.PFalse Predef.PTrue 5 -: In _: user error -CallStack (from HasCallStack): - error, called at src/compiler/GF/Compile/Compute/Concrete.hs:36:18 in main:GF.Compile.Compute.Concrete +user error "x" ++ Predef.nonExist ++ "y" "x" ++ Predef.BIND ++ "y" "x" ++ Predef.SOFT_BIND ++ "y"