GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-22 09:32:53 -06:00
Code Issues Packages Projects Releases Wiki 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.ShowTerm
import GF.Grammar.Lookup (allOpers,allOpersTo) import GF.Grammar.Lookup (allOpers,allOpersTo)
import GF.Compile.Rename(renameSourceTerm) 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.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
import GF.Infra.Dependencies(depGraph) import GF.Infra.Dependencies(depGraph)
import GF.Infra.CheckM(runCheck) import GF.Infra.CheckM(runCheck)
@@ -259,7 +259,7 @@ checkComputeTerm os sgr t =
((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
inferLType sgr [] t inferLType sgr [] t
let opts = modifyFlags (\fs->fs{optTrace=isOpt "trace" os}) 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 t2 = evalStr t1
checkPredefError t2 checkPredefError t2
where 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.Abstract
import GF.Compile.TypeCheck.Concrete(computeLType,checkLType,inferLType,ppType) import GF.Compile.TypeCheck.Concrete(computeLType,checkLType,inferLType,ppType)
import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType) 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
import GF.Grammar.Lexer 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 mty <- case mty of
Just (L loc typ) -> chIn loc "linearization type of" $ Just (L loc typ) -> chIn loc "linearization type of" $
(if False --flag optNewComp opts (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 typ <- computeLType gr [] typ
return (Just (L loc typ)) return (Just (L loc typ))
else do (typ,_) <- checkLType gr [] typ typeType 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 (Just (L loct ty), Just (L locd de)) -> do
ty' <- chIn loct "operation" $ ty' <- chIn loct "operation" $
(if False --flag optNewComp opts (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) else checkLType gr [] ty typeType >>= computeLType gr [] . fst)
(de',_) <- chIn locd "operation" $ (de',_) <- chIn locd "operation" $
(if False -- flag optNewComp opts (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') else checkLType gr [] de ty')
return (Just (L loct ty'), Just (L locd de')) return (Just (L loct ty'), Just (L locd de'))
(Nothing , Just (L locd de)) -> do (Nothing , Just (L locd de)) -> do
(de',ty') <- chIn locd "operation" $ (de',ty') <- chIn locd "operation" $
(if False -- flag optNewComp opts (if False -- flag optNewComp opts
then CN.inferLType (CN.resourceValues opts gr) de then CN.inferLType gr de
else inferLType gr [] de) else inferLType gr [] de)
return (Just (L locd ty'), Just (L locd de')) return (Just (L locd ty'), Just (L locd de'))
(Just (L loct ty), Nothing) -> do (Just (L loct ty), Nothing) -> do

111
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 -- | Functions for computing the values of terms in the concrete syntax, in
-- | preparation for PMCFG generation. -- | preparation for PMCFG generation.
module GF.Compile.Compute.Concrete module GF.Compile.Compute.Concrete
(GlobalEnv, GLocation, resourceValues, geLoc, geGrammar, (normalForm,
normalForm,
Value(..), Env, value2term, eval Value(..), Env, value2term, eval
) where ) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import GF.Grammar hiding (Env, VGen, VApp, VRecType) 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.Predef(cPredef,cErrorType,cTok,cStr,cTrace,cPBool)
import GF.Grammar.PatternMatch(matchPattern,measurePatt) import GF.Grammar.PatternMatch(matchPattern,measurePatt)
import GF.Grammar.Lockfield(isLockLabel,lockRecType) --unlockRecord,lockLabel import GF.Grammar.Lockfield(isLockLabel,lockRecType) --unlockRecord,lockLabel
import GF.Compile.Compute.Value hiding (Error) import GF.Compile.Compute.Value hiding (Error)
import GF.Compile.Compute.Predef(predef,predefName,delta) import GF.Compile.Compute.Predef(predef,predefName,delta)
import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok) 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.Data.Utilities(mapFst,mapSnd)
import GF.Infra.Option import GF.Infra.Option
import Data.STRef import Data.STRef
@@ -28,9 +27,9 @@ import qualified Data.Map as Map
-- * Main entry points -- * Main entry points
normalForm :: GlobalEnv -> L Ident -> Term -> Term normalForm :: Grammar -> L Ident -> Term -> Term
normalForm ge loc t = normalForm gr loc t =
case runEvalM (eval [] t [] >>= value2term 0) of case runEvalM gr (eval [] t [] >>= value2term 0) of
[t] -> t [t] -> t
ts -> FV ts ts -> FV ts
@@ -39,6 +38,7 @@ eval env (Vr x) vs = case lookup x env of
Nothing -> error "Unknown variable" Nothing -> error "Unknown variable"
eval env (Con f) vs = return (VApp f vs) eval env (Con f) vs = return (VApp f vs)
eval env (K t) vs = return (VStr t) 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 (App t1 t2) vs = do tnk <- newThunk env t2
eval env t1 (tnk : vs) eval env t1 (tnk : vs)
eval env (Abs b x t) [] = return (VClosure env (Abs b x t)) 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 eval env (Meta i) vs = do tnk <- newMeta i
return (VMeta tnk env vs) return (VMeta tnk env vs)
eval env (Typed t ty) vs = eval env t vs eval env (Typed t ty) vs = eval env t vs
eval env (C t1 t2) vs = do tnk1 <- newThunk env t1 eval env (R as) vs = do as <- mapM (\(lbl,(_,t)) -> fmap ((,) lbl) (newThunk env t)) as
tnk2 <- newThunk env t2 return (VR as)
return (VC tnk1 tnk2) 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 (FV ts) vs = msum [eval env t vs | t <- ts]
eval env t vs = error (show t)
apply v [] = return v apply v [] = return v
apply (VApp f vs0) vs = return (VApp f (vs0++vs)) 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 [] v <- eval ((x,tnk):env) t []
t <- value2term (i+1) v t <- value2term (i+1) v
return (Abs b (identS ('v':show i)) t) 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 (VStr tok) = return (K tok)
value2term i (VC tnk1 tnk2) = do value2term i (VC vs) = do
t1 <- force tnk1 [] >>= value2term i ts <- mapM (value2term i) vs
t2 <- force tnk2 [] >>= value2term i case ts of
return (C t1 t2) [] -> return Empty
(t:ts) -> return (foldl C t ts)
-----------------------------------------------------------------------
-- * 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)
----------------------------------------------------------------------- -----------------------------------------------------------------------
-- * Evaluation monad -- * Evaluation monad
type MetaThunks s = Map.Map MetaId (Thunk s) 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 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 instance Applicative (EvalM s) where
pure x = EvalM (\k -> k x) pure x = EvalM (\gr k -> k x)
(EvalM f) <*> (EvalM x) = EvalM (\k -> f (\f -> x (\x -> k (f x)))) (EvalM f) <*> (EvalM x) = EvalM (\gr k -> f gr (\f -> x gr (\x -> k (f x))))
instance Monad (EvalM s) where instance Monad (EvalM s) where
(EvalM f) >>= g = EvalM (\k -> f (\x -> case g x of (EvalM f) >>= g = EvalM (\gr k -> f gr (\x -> case g x of
EvalM g -> g k)) EvalM g -> g gr k))
instance Alternative (EvalM s) where instance Alternative (EvalM s) where
empty = EvalM (\k _ -> return) empty = EvalM (\gr k _ -> return)
(EvalM f) <|> (EvalM g) = EvalM (\k mt r -> f k mt r >>= \r -> g k mt r) (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 instance MonadPlus (EvalM s) where
runEvalM :: (forall s . EvalM s a) -> [a] runEvalM :: Grammar -> (forall s . EvalM s a) -> [a]
runEvalM f = reverse $ runEvalM gr f = reverse $
runST (case f of runST (case f of
EvalM f -> f (\x mt xs -> return (x:xs)) Map.empty []) 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) tnk <- newSTRef (Unevaluated env t)
k tnk mt r k tnk mt r
newMeta i = EvalM $ \k mt r -> newMeta i = EvalM $ \gr k mt r ->
if i == 0 if i == 0
then do tnk <- newSTRef (Unbound i) then do tnk <- newSTRef (Unbound i)
k tnk mt r k tnk mt r
@@ -136,24 +151,24 @@ newMeta i = EvalM $ \k mt r ->
Nothing -> do tnk <- newSTRef (Unbound i) Nothing -> do tnk <- newSTRef (Unbound i)
k tnk (Map.insert i tnk mt) r 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 [])) tnk <- newSTRef (Evaluated (VGen i []))
k tnk mt r k tnk mt r
force tnk vs = EvalM $ \k mt r -> do force tnk vs = EvalM $ \gr k mt r -> do
s <- readSTRef tnk s <- readSTRef tnk
case s of case s of
Unevaluated env t -> case eval env t vs of Unevaluated env t -> case eval env t vs of
EvalM f -> f (\v mt r -> do writeSTRef tnk (Evaluated v) EvalM f -> f gr (\v mt r -> do writeSTRef tnk (Evaluated v)
r <- k v mt r r <- k v mt r
writeSTRef tnk s writeSTRef tnk s
return r) mt r return r) mt r
Evaluated v -> case apply v vs of 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 s <- readSTRef tnk
case s of case s of
Evaluated v -> case apply v vs 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 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.Monad.ST
import Control.Applicative import Control.Applicative
import GF.Grammar.Grammar(MetaId,Term) import GF.Grammar.Grammar(MetaId,Term,Label)
import PGF2(BindType) import PGF2(BindType)
import GF.Infra.Ident(Ident) import GF.Infra.Ident(Ident)
@@ -23,5 +23,7 @@ data Value s
| VMeta (Thunk s) (Env s) [Thunk s] | VMeta (Thunk s) (Env s) [Thunk s]
| VGen {-# UNPACK #-} !Int [Thunk s] | VGen {-# UNPACK #-} !Int [Thunk s]
| VClosure (Env s) Term | VClosure (Env s) Term
| VR [(Label, Thunk s)]
| VP (Value s) Label
| VStr String | VStr String
| VC (Thunk s) (Thunk s) | VC [Value s]

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

@@ -10,7 +10,7 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Compile.GeneratePMCFG module GF.Compile.GeneratePMCFG
(generatePMCFG, pgfCncCat, addPMCFG, resourceValues (generatePMCFG, pgfCncCat, addPMCFG
) where ) where
import qualified PGF2 as PGF2 import qualified PGF2 as PGF2
@@ -26,7 +26,7 @@ import GF.Data.BacktrackM
import GF.Data.Operations import GF.Data.Operations
import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE, import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE,
import GF.Data.Utilities (updateNthM) --updateNth 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.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.List as List 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 :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule
generatePMCFG opts sgr opath cmo@(cm,cmi) = do 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 "" when (verbAtLeast opts Verbose) $ ePutStrLn ""
return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js}) return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js})
where where
cenv = resourceValues opts gr
gr = prependModule sgr cmo gr = prependModule sgr cmo
MTConcrete am = mtype cmi MTConcrete am = mtype cmi
@@ -69,14 +68,14 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m
return (a,(k,y):kys) return (a,(k,y):kys)
--addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info) --addPMCFG :: Options -> SourceGrammar -> 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 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++" ...") --when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...")
let pres = protoFCat gr res val let pres = protoFCat gr res val
pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont] pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
pmcfgEnv0 = emptyPMCFGEnv 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 let (seqs1,b1) = addSequencesB seqs b
pmcfgEnv1 = foldBM addRule pmcfgEnv1 = foldBM addRule
pmcfgEnv0 pmcfgEnv0
@@ -104,7 +103,7 @@ addPMCFG opts gr cenv opath am cm seqs id (CncFun mty@(Just (cat,cont,val)) mlin
newArgs = map getFIds newArgs' newArgs = map getFIds newArgs'
in addFunction env0 newCat fun newArgs in addFunction env0 newCat fun newArgs
addPMCFG opts gr cenv opath am cm seqs id (CncCat mty@(Just (L _ lincat)) addPMCFG opts gr opath am cm seqs id (CncCat mty@(Just (L _ lincat))
mdef@(Just (L loc1 def)) mdef@(Just (L loc1 def))
mref@(Just (L loc2 ref)) mref@(Just (L loc2 ref))
mprn mprn
@@ -115,7 +114,7 @@ addPMCFG opts gr cenv opath am cm seqs id (CncCat mty@(Just (L _ lincat))
pmcfgEnv0 = emptyPMCFGEnv pmcfgEnv0 = emptyPMCFGEnv
let lincont = [(Explicit, varStr, typeStr)] 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 let (seqs1,b1) = addSequencesB seqs b
pmcfgEnv1 = foldBM addLindef pmcfgEnv1 = foldBM addLindef
pmcfgEnv0 pmcfgEnv0
@@ -123,7 +122,7 @@ addPMCFG opts gr cenv opath am cm seqs id (CncCat mty@(Just (L _ lincat))
(pcat,[pvar]) (pcat,[pvar])
let lincont = [(Explicit, varStr, lincat)] 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 let (seqs2,b2) = addSequencesB seqs1 b
pmcfgEnv2 = foldBM addLinref pmcfgEnv2 = foldBM addLinref
pmcfgEnv1 pmcfgEnv1
@@ -145,12 +144,12 @@ addPMCFG opts gr cenv opath am cm seqs id (CncCat mty@(Just (L _ lincat))
!fun = mkArray lins !fun = mkArray lins
in addFunction env0 fidVar fun [newArg] 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 floc opath loc id = maybe (L loc id) (\path->L (External path loc) id) opath
convert opts gr cenv loc term ty@(_,val) pargs = convert opts gr loc term ty@(_,val) pargs =
case normalForm cenv loc (etaExpand ty term) of case normalForm gr loc (etaExpand ty term) of
Error s -> fail $ render $ ppL loc ("Predef.error: "++s) Error s -> fail $ render $ ppL loc ("Predef.error: "++s)
term -> return $ runCnvMonad gr (convertTerm opts CNil val term) (pargs,[]) term -> return $ runCnvMonad gr (convertTerm opts CNil val term) (pargs,[])
where 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.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
import GF.Infra.Option(Options,optionsPGF) import GF.Infra.Option(Options,optionsPGF)
import PGF2(Literal(..)) import PGF2(Literal(..))
import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues) import GF.Compile.Compute.Concrete(normalForm)
import GF.Grammar.Canonical as C import GF.Grammar.Canonical as C
import System.FilePath ((</>), (<.>)) import System.FilePath ((</>), (<.>))
import qualified Debug.Trace as T import qualified Debug.Trace as T
@@ -64,22 +64,21 @@ abstract2canonical absname gr =
-- the named abstract syntax in given the grammar. -- the named abstract syntax in given the grammar.
concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)] concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)]
concretes2canonical opts absname gr = concretes2canonical opts absname gr =
[(cncname,concrete2canonical gr cenv absname cnc cncmod) [(cncname,concrete2canonical gr absname cnc cncmod)
| let cenv = resourceValues opts gr, | cnc<-allConcretes gr absname,
cnc<-allConcretes gr absname,
let cncname = "canonical" </> render cnc <.> "gf" let cncname = "canonical" </> render cnc <.> "gf"
Ok cncmod = lookupModule gr cnc Ok cncmod = lookupModule gr cnc
] ]
-- | Generate Canonical GF for the given concrete module. -- | Generate Canonical GF for the given concrete module.
concrete2canonical :: G.Grammar -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete concrete2canonical :: G.Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
concrete2canonical gr cenv absname cnc modinfo = concrete2canonical gr absname cnc modinfo =
Concrete (modId cnc) (modId absname) (convFlags gr cnc) Concrete (modId cnc) (modId absname) (convFlags gr cnc)
(neededParamTypes S.empty (params defs)) (neededParamTypes S.empty (params defs))
[lincat | (_,Left lincat) <- defs] [lincat | (_,Left lincat) <- defs]
[lin | (_,Right lin) <- defs] [lin | (_,Right lin) <- defs]
where where
defs = concatMap (toCanonical gr absname cenv) . defs = concatMap (toCanonical gr absname) .
M.toList $ M.toList $
jments modinfo jments modinfo
@@ -92,8 +91,8 @@ concrete2canonical gr cenv absname cnc modinfo =
else let ((got,need),def) = paramType gr q else let ((got,need),def) = paramType gr q
in def++neededParamTypes (S.union got have) (S.toList need++qs) 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 :: G.Grammar -> ModuleName -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
toCanonical gr absname cenv (name,jment) = toCanonical gr absname (name,jment) =
case jment of case jment of
CncCat (Just (L loc typ)) _ _ pprn _ -> CncCat (Just (L loc typ)) _ _ pprn _ ->
[(pts,Left (LincatDef (gId name) (convType ntyp)))] [(pts,Left (LincatDef (gId name) (convType ntyp)))]
@@ -112,11 +111,11 @@ toCanonical gr absname cenv (name,jment) =
args = map snd params args = map snd params
AnyInd _ m -> case lookupOrigInfo gr (m,name) of 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 where
nf loc = normalForm cenv (L loc name) nf loc = normalForm gr (L loc name)
unAbs 0 t = t unAbs 0 t = t
unAbs n (Abs _ _ t) = unAbs (n-1) 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 cncs = map (mkConcr opts abs) cnc_infos
in newPGF gflags an abs cncs)-} in newPGF gflags an abs cncs)-}
where where
cenv = resourceValues opts gr
aflags = err (const noOptions) mflags (lookupModule gr am) aflags = err (const noOptions) mflags (lookupModule gr am)
mkAbstr :: ModuleName -> Map.Map PGF2.Fun Double -> IO PGF 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.Macros
import GF.Grammar.Lookup import GF.Grammar.Lookup
import GF.Grammar.Predef import GF.Grammar.Predef
import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues) import GF.Compile.Compute.Concrete(normalForm)
import GF.Data.Operations import GF.Data.Operations
import GF.Infra.Option import GF.Infra.Option
@@ -43,14 +43,12 @@ optimizeModule opts sgr m@(name,mi)
where where
oopts = opts `addOptions` mflags mi oopts = opts `addOptions` mflags mi
resenv = resourceValues oopts sgr
updateEvalInfo mi (i,info) = do 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)}) return (mi{jments=Map.insert i info (jments mi)})
evalInfo :: Options -> GlobalEnv -> SourceGrammar -> SourceModule -> Ident -> Info -> Err Info evalInfo :: Options -> SourceGrammar -> SourceModule -> Ident -> Info -> Err Info
evalInfo opts resenv sgr m c info = do evalInfo opts sgr m c info = do
(if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return () (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 (Just (L loc (factor param c 0 re)))
_ -> return pre -- indirection _ -> return pre -- indirection
let ppr' = fmap (evalPrintname resenv c) ppr let ppr' = fmap (evalPrintname sgr c) ppr
return (CncCat ptyp pde' pre' ppr' mpmcfg) 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 Just (L loc de) -> do de <- partEval opts gr (cont,val) de
return (Just (L loc (factor param c 0 de))) return (Just (L loc (factor param c 0 de)))
Nothing -> return pde 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 return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed
{- {-
ResOper pty pde ResOper pty pde
@@ -192,8 +190,8 @@ mkLinReference gr typ =
_ | Just _ <- isTypeInts typ -> Bad "no string" _ | Just _ <- isTypeInts typ -> Bad "no string"
_ -> Bad (render ("linearization type field cannot be" <+> typ)) _ -> Bad (render ("linearization type field cannot be" <+> typ))
evalPrintname :: GlobalEnv -> Ident -> L Term -> L Term evalPrintname :: Grammar -> Ident -> L Term -> L Term
evalPrintname resenv c (L loc pr) = L loc (normalForm resenv (L loc c) pr) evalPrintname gr c (L loc pr) = L loc (normalForm gr (L loc c) pr)
-- do even more: factor parametric branches -- 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 Data.Maybe(fromMaybe,isNothing)
import qualified Control.Monad.Fail as Fail 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 checkLType ge t ty = error "TODO: checkLType" {- runTcM $ do
vty <- liftErr (eval ge [] ty) vty <- liftErr (eval ge [] ty)
(t,_) <- tcRho ge [] t (Just vty) (t,_) <- tcRho ge [] t (Just vty)
t <- zonkTerm t t <- zonkTerm t
return (t,ty) -} return (t,ty) -}
inferLType :: GlobalEnv -> Term -> Check (Term, Type) inferLType :: Grammar -> Term -> Check (Term, Type)
inferLType ge t = error "TODO: inferLType" {- runTcM $ do inferLType ge t = error "TODO: inferLType" {- runTcM $ do
(t,ty) <- inferSigma ge [] t (t,ty) <- inferSigma ge [] t
t <- zonkTerm 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" ++ "a"; "b" ++ "b"}
variants {"a"; "b"} variants {"a"; "b"}
"c" "c"
variants {"a"; "b"} ++ variants {"a"; "b"} variants {"a" ++ "a"; "b" ++ "b"}
variants {"a"; "b"} variants {"a"; "b"}
"c" "c"
variants {"a"; "b"} ++ variants {"a"; "b"} variants {"a" ++ "a"; "b" ++ "b"}
variants {"a"; "b"} variants {"a"; "b"}
"c" ++ "c" "c" ++ "c"
"c" "c"