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

an FFI for GF

Browse Source
This commit is contained in:
Krasimir Angelov
2024-01-23 17:33:39 +01:00
parent c72fb9b958
commit 021e271f29
8 changed files with 99 additions and 83 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -20,7 +20,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) import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef)
import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType) import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
import GF.Compile.TypeCheck.Primitives(predefMod) import GF.Compile.TypeCheck.Primitives(predefMod)
@@ -257,7 +257,7 @@ checkComputeTerm os sgr0 t =
Just mo -> (sgr0,mo) Just mo -> (sgr0,mo)
t <- renameSourceTerm sgr mo t t <- renameSourceTerm sgr mo t
(t,_) <- inferLType sgr [] t (t,_) <- inferLType sgr [] t
fmap evalStr (normalForm sgr t) fmap evalStr (normalForm (Gl sgr stdPredef) t)
where where
-- ** Try to compute pre{...} tokens in token sequences -- ** Try to compute pre{...} tokens in token sequences
evalStr t = evalStr t =

10
src/compiler/api/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(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.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
import GF.Compile.Compute.Concrete(normalForm) import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef)
import GF.Grammar import GF.Grammar
import GF.Grammar.Lexer import GF.Grammar.Lexer
@@ -174,7 +174,7 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
mty <- case mty of mty <- case mty of
Just (L loc typ) -> chIn loc "linearization type of" $ do Just (L loc typ) -> chIn loc "linearization type of" $ do
(typ,_) <- checkLType gr [] typ typeType (typ,_) <- checkLType gr [] typ typeType
typ <- normalForm gr typ typ <- normalForm (Gl gr stdPredef) typ
return (Just (L loc typ)) return (Just (L loc typ))
Nothing -> return Nothing Nothing -> return Nothing
mdef <- case (mty,mdef) of mdef <- case (mty,mdef) of
@@ -217,7 +217,7 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) 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" $ do ty' <- chIn loct "operation" $ do
(ty,_) <- checkLType gr [] ty typeType (ty,_) <- checkLType gr [] ty typeType
normalForm gr ty normalForm (Gl gr stdPredef) ty
(de',_) <- chIn locd "operation" $ (de',_) <- chIn locd "operation" $
checkLType gr [] de ty' checkLType gr [] de ty'
return (Just (L loct ty'), Just (L locd de')) return (Just (L loct ty'), Just (L locd de'))
@@ -253,7 +253,7 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
mkParamValues sm c cnt ts [] = return (sm,cnt,[],[]) mkParamValues sm c cnt ts [] = return (sm,cnt,[],[])
mkParamValues sm@(mn,mi) c cnt ts ((p,co):pcs) = do mkParamValues sm@(mn,mi) c cnt ts ((p,co):pcs) = do
co <- mapM (\(b,v,ty) -> normalForm gr ty >>= \ty -> return (b,v,ty)) co co <- mapM (\(b,v,ty) -> normalForm (Gl gr stdPredef) ty >>= \ty -> return (b,v,ty)) co
sm <- case lookupIdent p (jments mi) of sm <- case lookupIdent p (jments mi) of
Ok (ResValue (L loc _) _) -> update sm p (ResValue (L loc (mkProdSimple co (QC (mn,c)))) cnt) Ok (ResValue (L loc _) _) -> update sm p (ResValue (L loc (mkProdSimple co (QC (mn,c)))) cnt)
Bad msg -> checkError (pp msg) Bad msg -> checkError (pp msg)
@@ -327,6 +327,6 @@ linTypeOfType cnc m (L loc typ) = do
plusRecType vars val plusRecType vars val
return ((Explicit,varX i,rec),cat) return ((Explicit,varX i,rec),cat)
lookLin (_,c) = checks [ --- rather: update with defLinType ? lookLin (_,c) = checks [ --- rather: update with defLinType ?
lookupLincat cnc m c >>= normalForm cnc lookupLincat cnc m c >>= normalForm (Gl cnc stdPredef)
,return defLinType ,return defLinType
] ]

123
src/compiler/api/GF/Compile/Compute/Concrete.hs
View File

@@ -1,13 +1,14 @@
{-# LANGUAGE RankNTypes, BangPatterns, CPP #-} {-# LANGUAGE RankNTypes, BangPatterns, CPP, ExistentialQuantification #-}
-- | 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
( normalForm ( normalForm, normalStringForm
, Value(..), Thunk, ThunkState(..), Env, Scope, showValue , Value(..), Thunk, ThunkState(..), Env, Scope, showValue
, MetaThunks, Constraint , MetaThunks, Constraint, Globals(..), ConstValue(..)
, EvalM(..), runEvalM, runEvalOneM, evalError, evalWarn , EvalM(..), runEvalM, runEvalOneM, evalError, evalWarn
, eval, apply, force, value2term, patternMatch , eval, apply, force, value2term, patternMatch, stdPredef
, unsafeIOToEvalM
, newThunk, newEvaluatedThunk , newThunk, newEvaluatedThunk
, newResiduation, newNarrowing, getVariables , newResiduation, newNarrowing, getVariables
, getRef, setRef , getRef, setRef
@@ -33,6 +34,7 @@ import Data.List
import Data.Char import Data.Char
import Control.Monad import Control.Monad
import Control.Monad.ST import Control.Monad.ST
import Control.Monad.ST.Unsafe
import Control.Applicative hiding (Const) import Control.Applicative hiding (Const)
import qualified Control.Monad.Fail as Fail import qualified Control.Monad.Fail as Fail
import qualified Data.Map as Map import qualified Data.Map as Map
@@ -41,13 +43,20 @@ import PGF2.Transactions(LIndex)
-- * Main entry points -- * Main entry points
normalForm :: Grammar -> Term -> Check Term normalForm :: Globals -> Term -> Check Term
normalForm gr t = normalForm globals t =
fmap mkFV (runEvalM gr (eval [] t [] >>= value2term [])) fmap mkFV (runEvalM globals (eval [] t [] >>= value2term []))
where where
mkFV [t] = t mkFV [t] = t
mkFV ts = FV ts mkFV ts = FV ts
normalStringForm :: Globals -> Term -> Check String
normalStringForm globals t =
fmap toStr (runEvalM globals (fmap value2string (eval [] t [])))
where
toStr [Const s] = s
toStr _ = ""
type Sigma s = Value s type Sigma s = Value s
type Constraint s = Value s type Constraint s = Value s
@@ -191,8 +200,8 @@ eval env (Let (x,(_,t1)) t2) vs = do tnk <- newThunk env t1
eval ((x,tnk):env) t2 vs eval ((x,tnk):env) t2 vs
eval env (Q q@(m,id)) vs eval env (Q q@(m,id)) vs
| m == cPredef = do vs' <- mapM force vs | m == cPredef = do vs' <- mapM force vs
mb_res <- evalPredef id vs' res <- evalPredef id vs'
case mb_res of case res of
Const res -> return res Const res -> return res
RunTime -> return (VApp q vs) RunTime -> return (VApp q vs)
NonExist -> return (VApp (cPredef,cNonExist) []) NonExist -> return (VApp (cPredef,cNonExist) [])
@@ -266,45 +275,32 @@ apply (VGen i vs0) vs = return (VGen i (vs0++vs))
apply (VClosure env (Abs b x t)) (v:vs) = eval ((x,v):env) t vs apply (VClosure env (Abs b x t)) (v:vs) = eval ((x,v):env) t vs
apply v [] = return v apply v [] = return v
evalPredef id [v]
| id == cLength = case value2string v of stdPredef :: Map.Map Ident ([Value s] -> EvalM s (ConstValue (Value s)))
Const s -> return (Const (VInt (genericLength s))) stdPredef = Map.fromList
_ -> return RunTime [(cLength, \[v] -> case value2string v of
evalPredef id [v1,v2] Const s -> return (Const (VInt (genericLength s)))
| id == cTake = return (fmap string2value (liftA2 genericTake (value2int v1) (value2string v2))) _ -> return RunTime)
evalPredef id [v1,v2] ,(cTake, \[v1,v2] -> return (fmap string2value (liftA2 genericTake (value2int v1) (value2string v2))))
| id == cDrop = return (fmap string2value (liftA2 genericDrop (value2int v1) (value2string v2))) ,(cDrop, \[v1,v2] -> return (fmap string2value (liftA2 genericDrop (value2int v1) (value2string v2))))
evalPredef id [v1,v2] ,(cTk, \[v1,v2] -> return (fmap string2value (liftA2 genericTk (value2int v1) (value2string v2))))
| id == cTk = return (fmap string2value (liftA2 genericTk (value2int v1) (value2string v2))) ,(cDp, \[v1,v2] -> return (fmap string2value (liftA2 genericDp (value2int v1) (value2string v2))))
,(cIsUpper,\[v] -> return (fmap toPBool (liftA (all isUpper) (value2string v))))
,(cToUpper,\[v] -> return (fmap string2value (liftA (map toUpper) (value2string v))))
,(cToLower,\[v] -> return (fmap string2value (liftA (map toLower) (value2string v))))
,(cEqStr, \[v1,v2] -> return (fmap toPBool (liftA2 (==) (value2string v1) (value2string v2))))
,(cOccur, \[v1,v2] -> return (fmap toPBool (liftA2 occur (value2string v1) (value2string v2))))
,(cOccurs, \[v1,v2] -> return (fmap toPBool (liftA2 occurs (value2string v1) (value2string v2))))
,(cEqInt, \[v1,v2] -> return (fmap toPBool (liftA2 (==) (value2int v1) (value2int v2))))
,(cLessInt,\[v1,v2] -> return (fmap toPBool (liftA2 (<) (value2int v1) (value2int v2))))
,(cPlus, \[v1,v2] -> return (fmap VInt (liftA2 (+) (value2int v1) (value2int v2))))
,(cError, \[v] -> case value2string v of
Const msg -> fail msg
_ -> fail "Indescribable error appeared")
]
where where
genericTk n = reverse . genericDrop n . reverse genericTk n = reverse . genericDrop n . reverse
evalPredef id [v1,v2]
| id == cDp = return (fmap string2value (liftA2 genericDp (value2int v1) (value2string v2)))
where
genericDp n = reverse . genericTake n . reverse genericDp n = reverse . genericTake n . reverse
evalPredef id [v]
| id == cIsUpper= return (fmap toPBool (liftA (all isUpper) (value2string v)))
evalPredef id [v]
| id == cToUpper= return (fmap string2value (liftA (map toUpper) (value2string v)))
evalPredef id [v]
| id == cToLower= return (fmap string2value (liftA (map toLower) (value2string v)))
evalPredef id [v1,v2]
| id == cEqStr = return (fmap toPBool (liftA2 (==) (value2string v1) (value2string v2)))
evalPredef id [v1,v2]
| id == cOccur = return (fmap toPBool (liftA2 occur (value2string v1) (value2string v2)))
evalPredef id [v1,v2]
| id == cOccurs = return (fmap toPBool (liftA2 occurs (value2string v1) (value2string v2)))
evalPredef id [v1,v2]
| id == cEqInt = return (fmap toPBool (liftA2 (==) (value2int v1) (value2int v2)))
evalPredef id [v1,v2]
| id == cLessInt= return (fmap toPBool (liftA2 (<) (value2int v1) (value2int v2)))
evalPredef id [v1,v2]
| id == cPlus = return (fmap VInt (liftA2 (+) (value2int v1) (value2int v2)))
evalPredef id [v]
| id == cError = case value2string v of
Const msg -> fail msg
_ -> fail "Indescribable error appeared"
evalPredef id vs = return RunTime
toPBool True = VApp (cPredef,cPTrue) [] toPBool True = VApp (cPredef,cPTrue) []
toPBool False = VApp (cPredef,cPFalse) [] toPBool False = VApp (cPredef,cPFalse) []
@@ -457,17 +453,17 @@ vtableSelect v0 ty tnks tnk2 vs = do
"cannot be evaluated at compile time.") "cannot be evaluated at compile time.")
susp i ki = EvalM $ \gr k mt d r msgs -> do susp i ki = EvalM $ \globals@(Gl gr _) k mt d r msgs -> do
s <- readSTRef i s <- readSTRef i
case s of case s of
Narrowing id (QC q) -> case lookupOrigInfo gr q of Narrowing id (QC q) -> case lookupOrigInfo gr q of
Ok (m,ResParam (Just (L _ ps)) _) -> bindParam gr k mt d r msgs s m ps Ok (m,ResParam (Just (L _ ps)) _) -> bindParam globals k mt d r msgs s m ps
Bad msg -> return (Fail (pp msg) msgs) Bad msg -> return (Fail (pp msg) msgs)
Narrowing id ty Narrowing id ty
| Just max <- isTypeInts ty | Just max <- isTypeInts ty
-> bindInt gr k mt d r msgs s 0 max -> bindInt globals k mt d r msgs s 0 max
Evaluated _ v -> case ki v of Evaluated _ v -> case ki v of
EvalM f -> f gr k mt d r msgs EvalM f -> f globals k mt d r msgs
_ -> k (VSusp i ki []) mt d r msgs _ -> k (VSusp i ki []) mt d r msgs
where where
bindParam gr k mt d r msgs s m [] = return (Success r msgs) bindParam gr k mt d r msgs s m [] = return (Success r msgs)
@@ -712,7 +708,8 @@ value2int _ = RunTime
type MetaThunks s = Map.Map MetaId (Thunk s) type MetaThunks s = Map.Map MetaId (Thunk s)
type Cont s r = MetaThunks s -> Int -> r -> [Message] -> ST s (CheckResult r [Message]) type Cont s r = MetaThunks s -> Int -> r -> [Message] -> ST s (CheckResult r [Message])
newtype EvalM s a = EvalM (forall r . Grammar -> (a -> Cont s r) -> Cont s r) data Globals = Gl Grammar (forall s . Map.Map Ident ([Value s] -> EvalM s (ConstValue (Value s))))
newtype EvalM s a = EvalM (forall r . Globals -> (a -> Cont s r) -> Cont s r)
instance Functor (EvalM s) where instance Functor (EvalM s) where
fmap f (EvalM g) = EvalM (\gr k -> g gr (k . f)) fmap f (EvalM g) = EvalM (\gr k -> g gr (k . f))
@@ -742,14 +739,14 @@ instance Alternative (EvalM s) where
instance MonadPlus (EvalM s) where instance MonadPlus (EvalM s) where
runEvalM :: Grammar -> (forall s . EvalM s a) -> Check [a] runEvalM :: Globals -> (forall s . EvalM s a) -> Check [a]
runEvalM gr f = Check $ \(es,ws) -> runEvalM gr f = Check $ \(es,ws) ->
case runST (case f of case runST (case f of
EvalM f -> f gr (\x mt _ xs ws -> return (Success (x:xs) ws)) Map.empty maxBound [] ws) of EvalM f -> f gr (\x mt _ xs ws -> return (Success (x:xs) ws)) Map.empty maxBound [] ws) of
Fail msg ws -> Fail msg (es,ws) Fail msg ws -> Fail msg (es,ws)
Success xs ws -> Success (reverse xs) (es,ws) Success xs ws -> Success (reverse xs) (es,ws)
runEvalOneM :: Grammar -> (forall s . EvalM s a) -> Check a runEvalOneM :: Globals -> (forall s . EvalM s a) -> Check a
runEvalOneM gr f = Check $ \(es,ws) -> runEvalOneM gr f = Check $ \(es,ws) ->
case runST (case f of case runST (case f of
EvalM f -> f gr (\x mt _ xs ws -> return (Success (x:xs) ws)) Map.empty maxBound [] ws) of EvalM f -> f gr (\x mt _ xs ws -> return (Success (x:xs) ws)) Map.empty maxBound [] ws) of
@@ -763,26 +760,32 @@ evalError msg = EvalM (\gr k _ _ r msgs -> return (Fail msg msgs))
evalWarn :: Message -> EvalM s () evalWarn :: Message -> EvalM s ()
evalWarn msg = EvalM (\gr k mt d r msgs -> k () mt d r (msg:msgs)) evalWarn msg = EvalM (\gr k mt d r msgs -> k () mt d r (msg:msgs))
evalPredef :: Ident -> [Value s] -> EvalM s (ConstValue (Value s))
evalPredef id vs = EvalM (\globals@(Gl _ predef) k mt d r msgs ->
case fmap (\f -> f vs) (Map.lookup id predef) of
Just (EvalM f) -> f globals k mt d r msgs
Nothing -> k RunTime mt d r msgs)
getResDef :: QIdent -> EvalM s Term getResDef :: QIdent -> EvalM s Term
getResDef q = EvalM $ \gr k mt d r msgs -> do getResDef q = EvalM $ \(Gl gr _) k mt d r msgs -> do
case lookupResDef gr q of case lookupResDef gr q of
Ok t -> k t mt d r msgs Ok t -> k t mt d r msgs
Bad msg -> return (Fail (pp msg) msgs) Bad msg -> return (Fail (pp msg) msgs)
getInfo :: QIdent -> EvalM s (ModuleName,Info) getInfo :: QIdent -> EvalM s (ModuleName,Info)
getInfo q = EvalM $ \gr k mt d r msgs -> do getInfo q = EvalM $ \(Gl gr _) k mt d r msgs -> do
case lookupOrigInfo gr q of case lookupOrigInfo gr q of
Ok res -> k res mt d r msgs Ok res -> k res mt d r msgs
Bad msg -> return (Fail (pp msg) msgs) Bad msg -> return (Fail (pp msg) msgs)
getResType :: QIdent -> EvalM s Type getResType :: QIdent -> EvalM s Type
getResType q = EvalM $ \gr k mt d r msgs -> do getResType q = EvalM $ \(Gl gr _) k mt d r msgs -> do
case lookupResType gr q of case lookupResType gr q of
Ok t -> k t mt d r msgs Ok t -> k t mt d r msgs
Bad msg -> return (Fail (pp msg) msgs) Bad msg -> return (Fail (pp msg) msgs)
getOverload :: Term -> QIdent -> EvalM s (Term,Type) getOverload :: Term -> QIdent -> EvalM s (Term,Type)
getOverload t q = EvalM $ \gr k mt d r msgs -> do getOverload t q = EvalM $ \(Gl gr _) k mt d r msgs -> do
case lookupOverloadTypes gr q of case lookupOverloadTypes gr q of
Ok ttys -> let err = "Overload resolution failed" $$ Ok ttys -> let err = "Overload resolution failed" $$
"of term " <+> pp t $$ "of term " <+> pp t $$
@@ -798,7 +801,7 @@ getOverload t q = EvalM $ \gr k mt d r msgs -> do
Bad msg -> return (Fail (pp msg) msgs) Bad msg -> return (Fail (pp msg) msgs)
getAllParamValues :: Type -> EvalM s [Term] getAllParamValues :: Type -> EvalM s [Term]
getAllParamValues ty = EvalM $ \gr k mt d r msgs -> getAllParamValues ty = EvalM $ \(Gl gr _) k mt d r msgs ->
case allParamValues gr ty of case allParamValues gr ty of
Ok ts -> k ts mt d r msgs Ok ts -> k ts mt d r msgs
Bad msg -> return (Fail (pp msg) msgs) Bad msg -> return (Fail (pp msg) msgs)
@@ -835,7 +838,7 @@ withVar d0 (EvalM f) = EvalM $ \gr k mt d1 r msgs ->
in f gr k mt d r msgs in f gr k mt d r msgs
getVariables :: EvalM s [(LVar,LIndex)] getVariables :: EvalM s [(LVar,LIndex)]
getVariables = EvalM $ \gr k mt d ws r -> do getVariables = EvalM $ \(Gl gr _) k mt d ws r -> do
ps <- metas2params gr (Map.elems mt) ps <- metas2params gr (Map.elems mt)
k ps mt d ws r k ps mt d ws r
where where
@@ -912,3 +915,7 @@ tnk2term xs tnk = EvalM $ \gr k mt d r msgs ->
Narrowing i _ -> k (Meta i) mt d r msgs Narrowing i _ -> k (Meta i) mt d r msgs
scopeEnv scope = zipWithM (\x i -> newEvaluatedThunk (VGen i []) >>= \tnk -> return (x,tnk)) (reverse scope) [0..] scopeEnv scope = zipWithM (\x i -> newEvaluatedThunk (VGen i []) >>= \tnk -> return (x,tnk)) (reverse scope) [0..]
unsafeIOToEvalM :: IO a -> EvalM s a
unsafeIOToEvalM f = EvalM (\gr k mt d r msgs -> unsafeIOToST f >>= \x -> k x mt d r msgs)

10
src/compiler/api/GF/Compile/GeneratePMCFG.hs
View File

@@ -61,7 +61,7 @@ addPMCFG opts cwd gr cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing
mprn <- case mprn of mprn <- case mprn of
Nothing -> return Nothing Nothing -> return Nothing
Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
prn <- normalForm gr prn prn <- normalForm (Gl gr stdPredef) prn
return (Just (L loc prn)) return (Just (L loc prn))
return (CncCat mty mdef mref mprn (Just (defs,refs)),seqs) return (CncCat mty mdef mref mprn (Just (defs,refs)),seqs)
addPMCFG opts cwd gr cmi id (CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) seqs = do addPMCFG opts cwd gr cmi id (CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) seqs = do
@@ -71,17 +71,17 @@ addPMCFG opts cwd gr cmi id (CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L lo
mprn <- case mprn of mprn <- case mprn of
Nothing -> return Nothing Nothing -> return Nothing
Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
prn <- normalForm gr prn prn <- normalForm (Gl gr stdPredef) prn
return (Just (L loc prn)) return (Just (L loc prn))
return (CncFun mty mlin mprn (Just rules),seqs) return (CncFun mty mlin mprn (Just rules),seqs)
addPMCFG opts cwd gr cmi id info seqs = return (info,seqs) addPMCFG opts cwd gr cmi id info seqs = return (info,seqs)
pmcfgForm :: Grammar -> Term -> Context -> Type -> SequenceSet -> Check ([Production],SequenceSet) pmcfgForm :: Grammar -> Term -> Context -> Type -> SequenceSet -> Check ([Production],SequenceSet)
pmcfgForm gr t ctxt ty seqs = do pmcfgForm gr t ctxt ty seqs = do
res <- runEvalM gr $ do res <- runEvalM (Gl gr stdPredef) $ do
(_,args) <- mapAccumM (\arg_no (_,_,ty) -> do (_,args) <- mapAccumM (\arg_no (_,_,ty) -> do
t <- EvalM (\gr k mt d r msgs -> do (mt,_,t) <- type2metaTerm gr arg_no mt 0 [] ty t <- EvalM (\(Gl gr _) k mt d r msgs -> do (mt,_,t) <- type2metaTerm gr arg_no mt 0 [] ty
k t mt d r msgs) k t mt d r msgs)
tnk <- newThunk [] t tnk <- newThunk [] t
return (arg_no+1,tnk)) return (arg_no+1,tnk))
0 ctxt 0 ctxt

6
src/compiler/api/GF/Compile/GrammarToCanonical.hs
View File

@@ -19,7 +19,7 @@ import GF.Infra.Ident(ModuleName(..),Ident,identW,ident2raw,rawIdentS,showIdent)
import GF.Infra.Option(Options,optionsPGF) import GF.Infra.Option(Options,optionsPGF)
import GF.Infra.CheckM import GF.Infra.CheckM
import PGF2(Literal(..)) import PGF2(Literal(..))
import GF.Compile.Compute.Concrete(normalForm) import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef)
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
@@ -93,13 +93,13 @@ concrete2canonical gr absname cnc modinfo = do
toCanonical gr absname (name,jment) = toCanonical gr absname (name,jment) =
case jment of case jment of
CncCat (Just (L loc typ)) _ _ pprn _ -> do CncCat (Just (L loc typ)) _ _ pprn _ -> do
ntyp <- normalForm gr typ ntyp <- normalForm (Gl gr stdPredef) typ
let pts = paramTypes gr ntyp let pts = paramTypes gr ntyp
return [(pts,Left (LincatDef (gId name) (convType ntyp)))] return [(pts,Left (LincatDef (gId name) (convType ntyp)))]
CncFun (Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn _ -> do CncFun (Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn _ -> do
let params = [(b,x)|(b,x,_)<-ctx] let params = [(b,x)|(b,x,_)<-ctx]
args = map snd params args = map snd params
e0 <- normalForm gr (mkAbs params (mkApp def (map Vr args))) e0 <- normalForm (Gl gr stdPredef) (mkAbs params (mkApp def (map Vr args)))
let e = cleanupRecordFields lincat (unAbs (length params) e0) let e = cleanupRecordFields lincat (unAbs (length params) e0)
tts = tableTypes gr [e] tts = tableTypes gr [e]
return [(tts,Right (LinDef (gId name) (map gId args) (convert gr e)))] return [(tts,Right (LinDef (gId name) (map gId args) (convert gr e)))]

6
src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
View File

@@ -10,7 +10,7 @@ import GF.Grammar.Lookup
import GF.Grammar.Predef import GF.Grammar.Predef
import GF.Grammar.PatternMatch import GF.Grammar.PatternMatch
import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord) import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord)
import GF.Compile.Compute.Concrete(normalForm) import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef)
import GF.Compile.TypeCheck.Primitives import GF.Compile.TypeCheck.Primitives
import Data.List import Data.List
@@ -215,7 +215,7 @@ inferLType gr g trm = case trm of
v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr] v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr]
v' <- case v' of v' <- case v' of
Q q -> do t <- lookupResDef gr q Q q -> do t <- lookupResDef gr q
t <- normalForm gr t t <- normalForm (Gl gr stdPredef) t
case t of case t of
EPatt _ _ p -> mkStrs p EPatt _ _ p -> mkStrs p
_ -> return v' _ -> return v'
@@ -325,7 +325,7 @@ inferLType gr g trm = case trm of
measurePatt gr p = measurePatt gr p =
case p of case p of
PM q -> do t <- lookupResDef gr q PM q -> do t <- lookupResDef gr q
t <- normalForm gr t t <- normalForm (Gl gr stdPredef) t
case t of case t of
EPatt minp maxp _ -> return (minp,maxp,p) EPatt minp maxp _ -> return (minp,maxp,p)
_ -> checkError ("Expected pattern macro, but found:" $$ nest 2 (pp t)) _ -> checkError ("Expected pattern macro, but found:" $$ nest 2 (pp t))

14
src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
View File

@@ -23,15 +23,15 @@ import qualified Data.Map as Map
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 :: Grammar -> Term -> Type -> Check (Term, Type) checkLType :: Globals -> Term -> Type -> Check (Term, Type)
checkLType gr t ty = runEvalOneM gr $ do checkLType globals t ty = runEvalOneM globals $ do
vty <- eval [] ty [] vty <- eval [] ty []
(t,_) <- tcRho [] t (Just vty) (t,_) <- tcRho [] t (Just vty)
t <- zonkTerm [] t t <- zonkTerm [] t
return (t,ty) return (t,ty)
inferLType :: Grammar -> Term -> Check (Term, Type) inferLType :: Globals -> Term -> Check (Term, Type)
inferLType gr t = runEvalOneM gr $ do inferLType globals t = runEvalOneM globals $ do
(t,ty) <- inferSigma [] t (t,ty) <- inferSigma [] t
t <- zonkTerm [] t t <- zonkTerm [] t
ty <- value2term [] ty ty <- value2term [] ty
@@ -171,7 +171,7 @@ tcRho scope (Meta _) mb_ty = do
return (Meta i, ty) return (Meta i, ty)
tcRho scope (Let (var, (mb_ann_ty, rhs)) body) mb_ty = do -- LET tcRho scope (Let (var, (mb_ann_ty, rhs)) body) mb_ty = do -- LET
(rhs,var_ty) <- case mb_ann_ty of (rhs,var_ty) <- case mb_ann_ty of
Nothing -> inferSigma scope rhs Nothing -> tcRho scope rhs Nothing
Just ann_ty -> do (ann_ty, _) <- tcRho scope ann_ty (Just vtypeType) Just ann_ty -> do (ann_ty, _) <- tcRho scope ann_ty (Just vtypeType)
env <- scopeEnv scope env <- scopeEnv scope
v_ann_ty <- eval env ann_ty [] v_ann_ty <- eval env ann_ty []
@@ -1086,7 +1086,9 @@ zonkTerm xs (Meta i) = do
st <- getRef tnk st <- getRef tnk
case st of case st of
Hole _ -> return (Meta i) Hole _ -> return (Meta i)
Residuation _ _ _ -> return (Meta i) Residuation _ scope v -> case v of
Just v -> zonkTerm xs =<< value2term (map fst scope) v
Nothing -> return (Meta i)
Narrowing _ _ -> return (Meta i) Narrowing _ _ -> return (Meta i)
Evaluated _ v -> zonkTerm xs =<< value2term xs v Evaluated _ v -> zonkTerm xs =<< value2term xs v
zonkTerm xs t = composOp (zonkTerm xs) t zonkTerm xs t = composOp (zonkTerm xs) t

9
src/compiler/api/GF/Term.hs
View File

@@ -1,4 +1,11 @@
module GF.Term (renameSourceTerm, inferLType, checkLType, normalForm) where module GF.Term (renameSourceTerm,
Globals(..), ConstValue(..), EvalM, stdPredef,
Value(..), showValue, newEvaluatedThunk,
evalError, evalWarn,
inferLType, checkLType,
normalForm, normalStringForm,
unsafeIOToEvalM
) where
import GF.Compile.Rename import GF.Compile.Rename
import GF.Compile.Compute.Concrete import GF.Compile.Compute.Concrete