msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

remove the Term(Error) constructor. Better propagation of errors.

Browse Source
This commit is contained in:
krangelov
2021-10-05 19:31:12 +02:00
parent dc59d9f3f9
commit 2a2d7269cf
16 changed files with 157 additions and 166 deletions
Download Patch File Download Diff File Expand all files Collapse all files

31
src/compiler/GF/Command/SourceCommands.hs
View File

@@ -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 =

41
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -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
]

44
src/compiler/GF/Compile/Compute/Concrete.hs
View File

@@ -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)

14
src/compiler/GF/Compile/ConcreteToHaskell.hs
View File

@@ -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

7
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -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]

79
src/compiler/GF/Compile/GrammarToCanonical.hs
View File

@@ -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

49
src/compiler/GF/Compile/Optimize.hs
View File

@@ -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

3
src/compiler/GF/CompileOne.hs
View File

@@ -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

26
src/compiler/GF/Compiler.hs
View File

@@ -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

2
src/compiler/GF/Grammar/Binary.hs
View File

@@ -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

1
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -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

6
src/compiler/GF/Grammar/Macros.hs
View File

@@ -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)

1
src/compiler/GF/Grammar/Printer.hs
View File

@@ -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

2
src/compiler/GF/Infra/CheckM.hs
View File

@@ -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,

13
src/compiler/GF/Infra/SIO.hs
View File

@@ -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."

4
testsuite/compiler/compute/predef.gfs.gold
View File

@@ -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"