GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki 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.Lookup (allOpers,allOpersTo)
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.Primitives(predefMod)
@@ -257,7 +257,7 @@ checkComputeTerm os sgr0 t =
Just mo -> (sgr0,mo)
t <- renameSourceTerm sgr mo t
(t,_) <- inferLType sgr [] t
fmap evalStr (normalForm sgr t)
fmap evalStr (normalForm (Gl sgr stdPredef) t)
where
-- ** Try to compute pre{...} tokens in token sequences
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.Concrete(checkLType,inferLType,ppType)
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.Lexer
@@ -174,7 +174,7 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
mty <- case mty of
Just (L loc typ) -> chIn loc "linearization type of" $ do
(typ,_) <- checkLType gr [] typ typeType
typ <- normalForm gr typ
typ <- normalForm (Gl gr stdPredef) typ
return (Just (L loc typ))
Nothing -> return Nothing
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
ty' <- chIn loct "operation" $ do
(ty,_) <- checkLType gr [] ty typeType
normalForm gr ty
normalForm (Gl gr stdPredef) ty
(de',_) <- chIn locd "operation" $
checkLType gr [] de ty'
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@(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
Ok (ResValue (L loc _) _) -> update sm p (ResValue (L loc (mkProdSimple co (QC (mn,c)))) cnt)
Bad msg -> checkError (pp msg)
@@ -327,6 +327,6 @@ linTypeOfType cnc m (L loc typ) = do
plusRecType vars val
return ((Explicit,varX i,rec),cat)
lookLin (_,c) = checks [ --- rather: update with defLinType ?
lookupLincat cnc m c >>= normalForm cnc
lookupLincat cnc m c >>= normalForm (Gl cnc stdPredef)
,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
-- | preparation for PMCFG generation.
module GF.Compile.Compute.Concrete
( normalForm
( normalForm, normalStringForm
, Value(..), Thunk, ThunkState(..), Env, Scope, showValue
, MetaThunks, Constraint
, MetaThunks, Constraint, Globals(..), ConstValue(..)
, EvalM(..), runEvalM, runEvalOneM, evalError, evalWarn
, eval, apply, force, value2term, patternMatch
, eval, apply, force, value2term, patternMatch, stdPredef
, unsafeIOToEvalM
, newThunk, newEvaluatedThunk
, newResiduation, newNarrowing, getVariables
, getRef, setRef
@@ -33,6 +34,7 @@ import Data.List
import Data.Char
import Control.Monad
import Control.Monad.ST
import Control.Monad.ST.Unsafe
import Control.Applicative hiding (Const)
import qualified Control.Monad.Fail as Fail
import qualified Data.Map as Map
@@ -41,13 +43,20 @@ import PGF2.Transactions(LIndex)
-- * Main entry points
normalForm :: Grammar -> Term -> Check Term
normalForm gr t =
fmap mkFV (runEvalM gr (eval [] t [] >>= value2term []))
normalForm :: Globals -> Term -> Check Term
normalForm globals t =
fmap mkFV (runEvalM globals (eval [] t [] >>= value2term []))
where
mkFV [t] = t
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 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 env (Q q@(m,id)) vs
| m == cPredef = do vs' <- mapM force vs
mb_res <- evalPredef id vs'
case mb_res of
res <- evalPredef id vs'
case res of
Const res -> return res
RunTime -> return (VApp q vs)
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 v [] = return v
evalPredef id [v]
| id == cLength = case value2string v of
Const s -> return (Const (VInt (genericLength s)))
_ -> return RunTime
evalPredef id [v1,v2]
| id == cTake = return (fmap string2value (liftA2 genericTake (value2int v1) (value2string v2)))
evalPredef id [v1,v2]
| id == cDrop = return (fmap string2value (liftA2 genericDrop (value2int v1) (value2string v2)))
evalPredef id [v1,v2]
| id == cTk = return (fmap string2value (liftA2 genericTk (value2int v1) (value2string v2)))
stdPredef :: Map.Map Ident ([Value s] -> EvalM s (ConstValue (Value s)))
stdPredef = Map.fromList
[(cLength, \[v] -> case value2string v of
Const s -> return (Const (VInt (genericLength s)))
_ -> return RunTime)
,(cTake, \[v1,v2] -> return (fmap string2value (liftA2 genericTake (value2int v1) (value2string v2))))
,(cDrop, \[v1,v2] -> return (fmap string2value (liftA2 genericDrop (value2int v1) (value2string v2))))
,(cTk, \[v1,v2] -> 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
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
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 False = VApp (cPredef,cPFalse) []
@@ -457,17 +453,17 @@ vtableSelect v0 ty tnks tnk2 vs = do
"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
case s 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)
Narrowing id 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
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
where
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 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
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
runEvalM :: Grammar -> (forall s . EvalM s a) -> Check [a]
runEvalM :: Globals -> (forall s . EvalM s a) -> Check [a]
runEvalM gr f = Check $ \(es,ws) ->
case runST (case f 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)
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) ->
case runST (case f 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 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 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
Ok t -> k t mt d r msgs
Bad msg -> return (Fail (pp msg) msgs)
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
Ok res -> k res mt d r msgs
Bad msg -> return (Fail (pp msg) msgs)
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
Ok t -> k t mt d r msgs
Bad msg -> return (Fail (pp msg) msgs)
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
Ok ttys -> let err = "Overload resolution failed" $$
"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)
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
Ok ts -> k ts mt d r 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
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)
k ps mt d ws r
where
@@ -912,3 +915,7 @@ tnk2term xs tnk = EvalM $ \gr k 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..]
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
Nothing -> return Nothing
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 (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
@@ -71,17 +71,17 @@ addPMCFG opts cwd gr cmi id (CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L lo
mprn <- case mprn of
Nothing -> return Nothing
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 (CncFun mty mlin mprn (Just rules),seqs)
addPMCFG opts cwd gr cmi id info seqs = return (info,seqs)
pmcfgForm :: Grammar -> Term -> Context -> Type -> SequenceSet -> Check ([Production],SequenceSet)
pmcfgForm gr t ctxt ty seqs = do
res <- runEvalM gr $ do
res <- runEvalM (Gl gr stdPredef) $ 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
k t mt d r msgs)
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)
tnk <- newThunk [] t
return (arg_no+1,tnk))
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.CheckM
import PGF2(Literal(..))
import GF.Compile.Compute.Concrete(normalForm)
import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef)
import GF.Grammar.Canonical as C
import System.FilePath ((</>), (<.>))
import qualified Debug.Trace as T
@@ -93,13 +93,13 @@ concrete2canonical gr absname cnc modinfo = do
toCanonical gr absname (name,jment) =
case jment of
CncCat (Just (L loc typ)) _ _ pprn _ -> do
ntyp <- normalForm gr typ
ntyp <- normalForm (Gl gr stdPredef) 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 (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)
tts = tableTypes 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.PatternMatch
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 Data.List
@@ -215,7 +215,7 @@ inferLType gr g trm = case trm of
v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr]
v' <- case v' of
Q q -> do t <- lookupResDef gr q
t <- normalForm gr t
t <- normalForm (Gl gr stdPredef) t
case t of
EPatt _ _ p -> mkStrs p
_ -> return v'
@@ -325,7 +325,7 @@ inferLType gr g trm = case trm of
measurePatt gr p =
case p of
PM q -> do t <- lookupResDef gr q
t <- normalForm gr t
t <- normalForm (Gl gr stdPredef) t
case t of
EPatt minp maxp _ -> return (minp,maxp,p)
_ -> 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 qualified Control.Monad.Fail as Fail
checkLType :: Grammar -> Term -> Type -> Check (Term, Type)
checkLType gr t ty = runEvalOneM gr $ do
checkLType :: Globals -> Term -> Type -> Check (Term, Type)
checkLType globals t ty = runEvalOneM globals $ do
vty <- eval [] ty []
(t,_) <- tcRho [] t (Just vty)
t <- zonkTerm [] t
return (t,ty)
inferLType :: Grammar -> Term -> Check (Term, Type)
inferLType gr t = runEvalOneM gr $ do
inferLType :: Globals -> Term -> Check (Term, Type)
inferLType globals t = runEvalOneM globals $ do
(t,ty) <- inferSigma [] t
t <- zonkTerm [] t
ty <- value2term [] ty
@@ -171,7 +171,7 @@ tcRho scope (Meta _) mb_ty = do
return (Meta i, ty)
tcRho scope (Let (var, (mb_ann_ty, rhs)) body) mb_ty = do -- LET
(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)
env <- scopeEnv scope
v_ann_ty <- eval env ann_ty []
@@ -1086,7 +1086,9 @@ zonkTerm xs (Meta i) = do
st <- getRef tnk
case st of
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)
Evaluated _ v -> zonkTerm xs =<< value2term xs v
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.Compute.Concrete