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

done with partial evaluation for records and variants

Browse Source
This commit is contained in:
krangelov
2021-09-24 15:00:34 +02:00
parent d17ca06faf
commit 3dc2af61a6
10 changed files with 116 additions and 104 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -18,7 +18,7 @@ import GF.Grammar.Parser (runP, pExp)
import GF.Grammar.ShowTerm
import GF.Grammar.Lookup (allOpers,allOpersTo)
import GF.Compile.Rename(renameSourceTerm)
import GF.Compile.Compute.Concrete(normalForm,resourceValues)
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)
@@ -259,7 +259,7 @@ checkComputeTerm os sgr t =
((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
inferLType sgr [] t
let opts = modifyFlags (\fs->fs{optTrace=isOpt "trace" os})
t1 = normalForm (resourceValues opts sgr) (L NoLoc identW) t
t1 = normalForm sgr (L NoLoc identW) t
t2 = evalStr t1
checkPredefError t2
where

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

@@ -29,7 +29,7 @@ import GF.Infra.Option
import GF.Compile.TypeCheck.Abstract
import GF.Compile.TypeCheck.Concrete(computeLType,checkLType,inferLType,ppType)
import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
import qualified GF.Compile.Compute.Concrete as CN(normalForm,resourceValues)
import qualified GF.Compile.Compute.Concrete as CN(normalForm)
import GF.Grammar
import GF.Grammar.Lexer
@@ -183,7 +183,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
mty <- case mty of
Just (L loc typ) -> chIn loc "linearization type of" $
(if False --flag optNewComp opts
then do (typ,_) <- CN.checkLType (CN.resourceValues opts gr) typ typeType
then do (typ,_) <- CN.checkLType gr typ typeType
typ <- computeLType gr [] typ
return (Just (L loc typ))
else do (typ,_) <- checkLType gr [] typ typeType
@@ -230,17 +230,17 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
(Just (L loct ty), Just (L locd de)) -> do
ty' <- chIn loct "operation" $
(if False --flag optNewComp opts
then CN.checkLType (CN.resourceValues opts gr) ty typeType >>= return . CN.normalForm (CN.resourceValues opts gr) (L loct c) . fst -- !!
then CN.checkLType gr ty typeType >>= return . CN.normalForm gr (L loct c) . fst -- !!
else checkLType gr [] ty typeType >>= computeLType gr [] . fst)
(de',_) <- chIn locd "operation" $
(if False -- flag optNewComp opts
then CN.checkLType (CN.resourceValues opts gr) de ty'
then CN.checkLType gr de ty'
else 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 (CN.resourceValues opts gr) de
then CN.inferLType gr de
else inferLType gr [] de)
return (Just (L locd ty'), Just (L locd de'))
(Just (L loct ty), Nothing) -> do

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

@@ -3,21 +3,20 @@
-- | Functions for computing the values of terms in the concrete syntax, in
-- | preparation for PMCFG generation.
module GF.Compile.Compute.Concrete
(GlobalEnv, GLocation, resourceValues, geLoc, geGrammar,
normalForm,
(normalForm,
Value(..), Env, value2term, eval
) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import GF.Grammar hiding (Env, VGen, VApp, VRecType)
import GF.Grammar.Lookup(lookupResDefLoc,allParamValues)
import GF.Grammar.Lookup(lookupResDef,allParamValues)
import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr,cTrace,cPBool)
import GF.Grammar.PatternMatch(matchPattern,measurePatt)
import GF.Grammar.Lockfield(isLockLabel,lockRecType) --unlockRecord,lockLabel
import GF.Compile.Compute.Value hiding (Error)
import GF.Compile.Compute.Predef(predef,predefName,delta)
import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok)
import GF.Data.Operations(Err,err,errIn,maybeErr,mapPairsM)
import GF.Data.Operations(Err(..),err,errIn,maybeErr,mapPairsM)
import GF.Data.Utilities(mapFst,mapSnd)
import GF.Infra.Option
import Data.STRef
@@ -28,9 +27,9 @@ import qualified Data.Map as Map
-- * Main entry points
normalForm :: GlobalEnv -> L Ident -> Term -> Term
normalForm ge loc t =
case runEvalM (eval [] t [] >>= value2term 0) of
normalForm :: Grammar -> L Ident -> Term -> Term
normalForm gr loc t =
case runEvalM gr (eval [] t [] >>= value2term 0) of
[t] -> t
ts -> FV ts
@@ -39,6 +38,7 @@ eval env (Vr x) vs = case lookup x env of
Nothing -> error "Unknown variable"
eval env (Con f) vs = return (VApp f vs)
eval env (K t) vs = return (VStr t)
eval env Empty vs = return (VC [])
eval env (App t1 t2) vs = do tnk <- newThunk env t2
eval env t1 (tnk : vs)
eval env (Abs b x t) [] = return (VClosure env (Abs b x t))
@@ -46,10 +46,27 @@ eval env (Abs b x t) (v:vs) = eval ((x,v):env) t vs
eval env (Meta i) vs = do tnk <- newMeta i
return (VMeta tnk env vs)
eval env (Typed t ty) vs = eval env t vs
eval env (C t1 t2) vs = do tnk1 <- newThunk env t1
tnk2 <- newThunk env t2
return (VC tnk1 tnk2)
eval env (R as) vs = do as <- mapM (\(lbl,(_,t)) -> fmap ((,) lbl) (newThunk env t)) as
return (VR as)
eval env (P t lbl) vs = do v <- eval env t []
case v of
VR as -> case lookup lbl as of
Nothing -> error ("Missing value for label "++show lbl)
Just tnk -> force tnk vs
v -> return (VP v lbl)
eval env (Let (x,(_,t1)) t2) vs = do tnk <- newThunk env t1
eval ((x,tnk):env) t2 vs
eval env (Q q) vs = do t <- lookupGlobal q
eval env t vs
eval env (C t1 t2) vs = do v1 <- eval env t1 vs
v2 <- eval env t2 vs
case (v1,v2) of
(VC vs1,VC vs2) -> return (VC (vs1++vs2))
(VC vs1,v2 ) -> return (VC (vs1++[v2]))
(v1, VC vs2) -> return (VC ([v1]++vs2))
(v1, v2 ) -> return (VC [v1,v2])
eval env (FV ts) vs = msum [eval env t vs | t <- ts]
eval env t vs = error (show t)
apply v [] = return v
apply (VApp f vs0) vs = return (VApp f (vs0++vs))
@@ -72,62 +89,60 @@ 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 (VR as) = do
as <- mapM (\(lbl,tnk) -> fmap (\t -> (lbl,(Nothing,t))) (force tnk [] >>= value2term i)) as
return (R as)
value2term i (VP v lbl) = do
t <- value2term i v
return (P t lbl)
value2term i (VStr tok) = return (K tok)
value2term i (VC tnk1 tnk2) = do
t1 <- force tnk1 [] >>= value2term i
t2 <- force tnk2 [] >>= value2term i
return (C t1 t2)
-----------------------------------------------------------------------
-- * Environments
data GlobalEnv = GE Grammar Options GLocation
type GLocation = L Ident
geLoc (GE _ _ loc) = loc
geGrammar (GE gr _ _ ) = gr
-- | Convert operators once, not every time they are looked up
resourceValues :: Options -> SourceGrammar -> GlobalEnv
resourceValues opts gr = GE gr opts (L NoLoc identW)
value2term i (VC vs) = do
ts <- mapM (value2term i) vs
case ts of
[] -> return Empty
(t:ts) -> return (foldl C t ts)
-----------------------------------------------------------------------
-- * Evaluation monad
type MetaThunks s = Map.Map MetaId (Thunk s)
newtype EvalM s a = EvalM (forall r . (a -> MetaThunks s -> r -> ST s r) -> MetaThunks s -> r -> ST s r)
newtype EvalM s a = EvalM (forall r . Grammar -> (a -> MetaThunks s -> r -> ST s r) -> MetaThunks s -> r -> ST s r)
instance Functor (EvalM s) where
fmap f (EvalM g) = EvalM (\k -> g (k . f))
fmap f (EvalM g) = EvalM (\gr k -> g gr (k . f))
instance Applicative (EvalM s) where
pure x = EvalM (\k -> k x)
(EvalM f) <*> (EvalM x) = EvalM (\k -> f (\f -> x (\x -> k (f x))))
pure x = EvalM (\gr k -> k x)
(EvalM f) <*> (EvalM x) = EvalM (\gr k -> f gr (\f -> x gr (\x -> k (f x))))
instance Monad (EvalM s) where
(EvalM f) >>= g = EvalM (\k -> f (\x -> case g x of
EvalM g -> g k))
(EvalM f) >>= g = EvalM (\gr k -> f gr (\x -> case g x of
EvalM g -> g gr k))
instance Alternative (EvalM s) where
empty = EvalM (\k _ -> return)
(EvalM f) <|> (EvalM g) = EvalM (\k mt r -> f k mt r >>= \r -> g k mt r)
empty = EvalM (\gr k _ -> return)
(EvalM f) <|> (EvalM g) = EvalM (\gr k mt r -> f gr k mt r >>= \r -> g gr k mt r)
instance MonadPlus (EvalM s) where
runEvalM :: (forall s . EvalM s a) -> [a]
runEvalM f = reverse $
runST (case f of
EvalM f -> f (\x mt xs -> return (x:xs)) Map.empty [])
runEvalM :: Grammar -> (forall s . EvalM s a) -> [a]
runEvalM gr f = reverse $
runST (case f of
EvalM f -> f gr (\x mt xs -> return (x:xs)) Map.empty [])
newThunk env t = EvalM $ \k mt r -> do
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 -> error msg
newThunk env t = EvalM $ \gr k mt r -> do
tnk <- newSTRef (Unevaluated env t)
k tnk mt r
newMeta i = EvalM $ \k mt r ->
newMeta i = EvalM $ \gr k mt r ->
if i == 0
then do tnk <- newSTRef (Unbound i)
k tnk mt r
@@ -136,24 +151,24 @@ newMeta i = EvalM $ \k mt r ->
Nothing -> do tnk <- newSTRef (Unbound i)
k tnk (Map.insert i tnk mt) r
newGen i = EvalM $ \k mt r -> do
newGen i = EvalM $ \gr k mt r -> do
tnk <- newSTRef (Evaluated (VGen i []))
k tnk mt r
force tnk vs = EvalM $ \k mt r -> do
force tnk vs = EvalM $ \gr k mt r -> do
s <- readSTRef tnk
case s of
Unevaluated env t -> case eval env t vs of
EvalM f -> f (\v mt r -> do writeSTRef tnk (Evaluated v)
r <- k v mt r
writeSTRef tnk s
return r) mt r
EvalM f -> f gr (\v mt r -> do writeSTRef tnk (Evaluated v)
r <- k v mt r
writeSTRef tnk s
return r) mt r
Evaluated v -> case apply v vs of
EvalM f -> f k mt r
EvalM f -> f gr k mt r
zonk tnk vs = EvalM $ \k mt r -> do
zonk tnk vs = EvalM $ \gr k mt r -> do
s <- readSTRef tnk
case s of
Evaluated v -> case apply v vs of
EvalM f -> f (k . Left) mt r
EvalM f -> f gr (k . Left) mt r
Unbound i -> k (Right i) mt r

6
src/compiler/GF/Compile/Compute/Value.hs
View File

@@ -6,7 +6,7 @@ import Control.Monad
import Control.Monad.ST
import Control.Applicative
import GF.Grammar.Grammar(MetaId,Term)
import GF.Grammar.Grammar(MetaId,Term,Label)
import PGF2(BindType)
import GF.Infra.Ident(Ident)
@@ -23,5 +23,7 @@ data Value s
| VMeta (Thunk s) (Env s) [Thunk s]
| VGen {-# UNPACK #-} !Int [Thunk s]
| VClosure (Env s) Term
| VR [(Label, Thunk s)]
| VP (Value s) Label
| VStr String
| VC (Thunk s) (Thunk s)
| VC [Value s]

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

@@ -10,7 +10,7 @@
-----------------------------------------------------------------------------
module GF.Compile.GeneratePMCFG
(generatePMCFG, pgfCncCat, addPMCFG, resourceValues
(generatePMCFG, pgfCncCat, addPMCFG
) where
import qualified PGF2 as PGF2
@@ -26,7 +26,7 @@ import GF.Data.BacktrackM
import GF.Data.Operations
import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE,
import GF.Data.Utilities (updateNthM) --updateNth
import GF.Compile.Compute.Concrete(normalForm,resourceValues)
import GF.Compile.Compute.Concrete(normalForm)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.List as List
@@ -49,11 +49,10 @@ import qualified Control.Monad.Fail as Fail
--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)
(seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr opath am cm) Map.empty (jments cmi)
when (verbAtLeast opts Verbose) $ ePutStrLn ""
return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js})
where
cenv = resourceValues opts gr
gr = prependModule sgr cmo
MTConcrete am = mtype cmi
@@ -69,14 +68,14 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m
return (a,(k,y):kys)
--addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
addPMCFG opts gr cenv opath am cm seqs id (CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
--addPMCFG :: Options -> SourceGrammar -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
addPMCFG opts gr opath am cm seqs id (CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
--when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...")
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 (floc opath loc id) term (cont,val) pargs
b <- convert opts gr (floc opath loc id) term (cont,val) pargs
let (seqs1,b1) = addSequencesB seqs b
pmcfgEnv1 = foldBM addRule
pmcfgEnv0
@@ -104,18 +103,18 @@ addPMCFG opts gr cenv opath am cm seqs id (CncFun mty@(Just (cat,cont,val)) mlin
newArgs = map getFIds newArgs'
in addFunction env0 newCat fun newArgs
addPMCFG opts gr cenv opath am cm seqs id (CncCat mty@(Just (L _ lincat))
mdef@(Just (L loc1 def))
mref@(Just (L loc2 ref))
mprn
Nothing) = do
addPMCFG opts gr opath am cm seqs id (CncCat mty@(Just (L _ lincat))
mdef@(Just (L loc1 def))
mref@(Just (L loc2 ref))
mprn
Nothing) = do
let pcat = protoFCat gr (am,id) lincat
pvar = protoFCat gr (MN identW,cVar) typeStr
pmcfgEnv0 = emptyPMCFGEnv
let lincont = [(Explicit, varStr, typeStr)]
b <- convert opts gr cenv (floc opath loc1 id) def (lincont,lincat) [pvar]
b <- convert opts gr (floc opath loc1 id) def (lincont,lincat) [pvar]
let (seqs1,b1) = addSequencesB seqs b
pmcfgEnv1 = foldBM addLindef
pmcfgEnv0
@@ -123,7 +122,7 @@ addPMCFG opts gr cenv opath am cm seqs id (CncCat mty@(Just (L _ lincat))
(pcat,[pvar])
let lincont = [(Explicit, varStr, lincat)]
b <- convert opts gr cenv (floc opath loc2 id) ref (lincont,typeStr) [pcat]
b <- convert opts gr (floc opath loc2 id) ref (lincont,typeStr) [pcat]
let (seqs2,b2) = addSequencesB seqs1 b
pmcfgEnv2 = foldBM addLinref
pmcfgEnv1
@@ -145,12 +144,12 @@ addPMCFG opts gr cenv opath am cm seqs id (CncCat mty@(Just (L _ lincat))
!fun = mkArray lins
in addFunction env0 fidVar fun [newArg]
addPMCFG opts gr cenv opath am cm seqs id info = return (seqs, info)
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 cenv loc term ty@(_,val) pargs =
case normalForm cenv loc (etaExpand ty term) of
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,[])
where

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

@@ -20,7 +20,7 @@ import GF.Compile.Compute.Predef(predef)
import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
import GF.Infra.Option(Options,optionsPGF)
import PGF2(Literal(..))
import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
import GF.Compile.Compute.Concrete(normalForm)
import GF.Grammar.Canonical as C
import System.FilePath ((</>), (<.>))
import qualified Debug.Trace as T
@@ -64,22 +64,21 @@ abstract2canonical absname gr =
-- the named abstract syntax in given the grammar.
concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)]
concretes2canonical opts absname gr =
[(cncname,concrete2canonical gr cenv absname cnc cncmod)
| let cenv = resourceValues opts gr,
cnc<-allConcretes gr absname,
[(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 -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
concrete2canonical gr cenv absname cnc modinfo =
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]
where
defs = concatMap (toCanonical gr absname cenv) .
defs = concatMap (toCanonical gr absname) .
M.toList $
jments modinfo
@@ -92,8 +91,8 @@ concrete2canonical gr cenv absname cnc modinfo =
else let ((got,need),def) = paramType gr q
in def++neededParamTypes (S.union got have) (S.toList need++qs)
-- toCanonical :: G.Grammar -> ModuleName -> GlobalEnv -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
toCanonical gr absname cenv (name,jment) =
-- 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)))]
@@ -112,11 +111,11 @@ toCanonical gr absname cenv (name,jment) =
args = map snd params
AnyInd _ m -> case lookupOrigInfo gr (m,name) of
Ok (m,jment) -> toCanonical gr absname cenv (name,jment)
Ok (m,jment) -> toCanonical gr absname (name,jment)
_ -> []
_ -> []
where
nf loc = normalForm cenv (L loc name)
nf loc = normalForm gr (L loc name)
unAbs 0 t = t
unAbs n (Abs _ _ t) = unAbs (n-1) t

1
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -44,7 +44,6 @@ grammar2PGF opts gr am probs = do
cncs = map (mkConcr opts abs) cnc_infos
in newPGF gflags an abs cncs)-}
where
cenv = resourceValues opts gr
aflags = err (const noOptions) mflags (lookupModule gr am)
mkAbstr :: ModuleName -> Map.Map PGF2.Fun Double -> IO PGF

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

@@ -21,7 +21,7 @@ import GF.Grammar.Printer
import GF.Grammar.Macros
import GF.Grammar.Lookup
import GF.Grammar.Predef
import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
import GF.Compile.Compute.Concrete(normalForm)
import GF.Data.Operations
import GF.Infra.Option
@@ -43,14 +43,12 @@ optimizeModule opts sgr m@(name,mi)
where
oopts = opts `addOptions` mflags mi
resenv = resourceValues oopts sgr
updateEvalInfo mi (i,info) = do
info <- evalInfo oopts resenv sgr (name,mi) i info
info <- evalInfo oopts sgr (name,mi) i info
return (mi{jments=Map.insert i info (jments mi)})
evalInfo :: Options -> GlobalEnv -> SourceGrammar -> SourceModule -> Ident -> Info -> Err Info
evalInfo opts resenv sgr m c info = do
evalInfo :: Options -> SourceGrammar -> SourceModule -> Ident -> Info -> Err Info
evalInfo opts sgr m c info = do
(if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return ()
@@ -77,7 +75,7 @@ evalInfo opts resenv sgr m c info = do
return (Just (L loc (factor param c 0 re)))
_ -> return pre -- indirection
let ppr' = fmap (evalPrintname resenv c) ppr
let ppr' = fmap (evalPrintname sgr c) ppr
return (CncCat ptyp pde' pre' ppr' mpmcfg)
@@ -87,7 +85,7 @@ evalInfo opts resenv 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 resenv c) ppr
let ppr' = fmap (evalPrintname sgr c) ppr
return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed
{-
ResOper pty pde
@@ -192,8 +190,8 @@ mkLinReference gr typ =
_ | Just _ <- isTypeInts typ -> Bad "no string"
_ -> Bad (render ("linearization type field cannot be" <+> typ))
evalPrintname :: GlobalEnv -> Ident -> L Term -> L Term
evalPrintname resenv c (L loc pr) = L loc (normalForm resenv (L loc c) pr)
evalPrintname :: Grammar -> Ident -> L Term -> L Term
evalPrintname gr c (L loc pr) = L loc (normalForm gr (L loc c) pr)
-- do even more: factor parametric branches

4
src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
View File

@@ -22,14 +22,14 @@ import qualified Data.IntMap as IntMap
import Data.Maybe(fromMaybe,isNothing)
import qualified Control.Monad.Fail as Fail
checkLType :: GlobalEnv -> Term -> Type -> Check (Term, Type)
checkLType :: Grammar -> Term -> Type -> Check (Term, Type)
checkLType ge t ty = error "TODO: checkLType" {- runTcM $ do
vty <- liftErr (eval ge [] ty)
(t,_) <- tcRho ge [] t (Just vty)
t <- zonkTerm t
return (t,ty) -}
inferLType :: GlobalEnv -> Term -> Check (Term, Type)
inferLType :: Grammar -> Term -> Check (Term, Type)
inferLType ge t = error "TODO: inferLType" {- runTcM $ do
(t,ty) <- inferSigma ge [] t
t <- zonkTerm t

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

@@ -2,10 +2,10 @@ variants {"hello"; "hello" ++ "hello"}
variants {"a" ++ "a"; "b" ++ "b"}
variants {"a"; "b"}
"c"
variants {"a"; "b"} ++ variants {"a"; "b"}
variants {"a" ++ "a"; "b" ++ "b"}
variants {"a"; "b"}
"c"
variants {"a"; "b"} ++ variants {"a"; "b"}
variants {"a" ++ "a"; "b" ++ "b"}
variants {"a"; "b"}
"c" ++ "c"
"c"