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

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