GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 11:42:49 -06:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'majestic' of github.com:GrammaticalFramework/gf-core into majestic

Browse Source
This commit is contained in:
Krasimir Angelov
2023-12-05 15:03:27 +01:00
parent 85f3aa3eca d0e3c30ea6
commit ad57f73298
10 changed files with 1213 additions and 845 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -1,5 +1,6 @@
-- | Commands requiring source grammar in env -- | Commands requiring source grammar in env
module GF.Command.SourceCommands(HasGrammar(..),sourceCommands) where module GF.Command.SourceCommands(HasGrammar(..),sourceCommands) where
import Prelude hiding (putStrLn) import Prelude hiding (putStrLn)
import qualified Prelude as P(putStrLn) import qualified Prelude as P(putStrLn)
import Data.List(nub,isInfixOf,isPrefixOf) import Data.List(nub,isInfixOf,isPrefixOf)
@@ -21,6 +22,7 @@ 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)
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.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts) import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
import GF.Command.CommandInfo import GF.Command.CommandInfo
@@ -37,8 +39,8 @@ sourceCommands = Map.fromList [
explanation = unlines [ explanation = unlines [
"Compute TERM by concrete syntax definitions. Uses the topmost", "Compute TERM by concrete syntax definitions. Uses the topmost",
"module (the last one imported) to resolve constant names.", "module (the last one imported) to resolve constant names.",
"N.B.1 You need the flag -retain when importing the grammar, if you want", "N.B.1 You need the flag -retain or -resource when importing the grammar,",
"the definitions to be retained after compilation.", "if you want the definitions to be available after compilation.",
"N.B.2 The resulting term is not a tree in the sense of abstract syntax", "N.B.2 The resulting term is not a tree in the sense of abstract syntax",
"and hence not a valid input to a Tree-expecting command.", "and hence not a valid input to a Tree-expecting command.",
"This command must be a line of its own, and thus cannot be a part", "This command must be a line of its own, and thus cannot be a part",
@@ -109,8 +111,9 @@ sourceCommands = Map.fromList [
synopsis = "show all operations in scope, possibly restricted to a value type", synopsis = "show all operations in scope, possibly restricted to a value type",
explanation = unlines [ explanation = unlines [
"Show the names and type signatures of all operations available in the current resource.", "Show the names and type signatures of all operations available in the current resource.",
"This command requires a source grammar to be in scope, imported with 'import -retain'.", "If no grammar is loaded with 'import -retain' or 'import -resource',",
"The operations include the parameter constructors that are in scope.", "then only the predefined operations are in scope.",
"The operations include also the parameter constructors that are in scope.",
"The optional TYPE filters according to the value type.", "The optional TYPE filters according to the value type.",
"The grep STRINGs filter according to other substrings of the type signatures."{-, "The grep STRINGs filter according to other substrings of the type signatures."{-,
"This command must be a line of its own, and thus cannot be a part", "This command must be a line of its own, and thus cannot be a part",
@@ -198,24 +201,21 @@ sourceCommands = Map.fromList [
| otherwise = unwords $ map prTerm ops | otherwise = unwords $ map prTerm ops
return $ fromString printed return $ fromString printed
show_operations os ts sgr = fmap fst $ runCheck $ show_operations os ts sgr0 = fmap fst $ runCheck $ do
case greatestResource sgr of let (sgr,mo) = case greatestResource sgr0 of
Nothing -> checkError (pp "no source grammar in scope; did you import with -retain?") Nothing -> (mGrammar [predefMod], fst predefMod)
Just mo -> do Just mo -> (sgr0,mo)
let greps = map valueString (listFlags "grep" os) greps = map valueString (listFlags "grep" os)
let isRaw = isOpt "raw" os ops <- case ts of
ops <- case ts of _:_ -> do let Right t = runP pExp (UTF8.fromString (unwords ts))
_:_ -> do ty <- checkComputeTerm os sgr t
let Right t = runP pExp (UTF8.fromString (unwords ts)) return $ allOpersTo sgr ty
ty <- checkComputeTerm os sgr t _ -> return $ allOpers sgr
return $ allOpersTo sgr ty let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
_ -> return $ allOpers sgr printer = showTerm sgr TermPrintDefault
let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops] (if isOpt "raw" os then Qualified else Unqualified)
let printer = if isRaw printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
then showTerm sgr TermPrintDefault Qualified return . fromString $ unlines [l | l <- printed, all (`isInfixOf` l) greps]
else (render . TC.ppType)
let printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
return . fromString $ unlines [l | l <- printed, all (`isInfixOf` l) greps]
show_source os ts sgr = do show_source os ts sgr = do
let strip = if isOpt "strip" os then stripSourceGrammar else id let strip = if isOpt "strip" os then stripSourceGrammar else id
@@ -251,9 +251,10 @@ sourceCommands = Map.fromList [
P.putStrLn "wrote graph in file _gfdepgraph.dot" P.putStrLn "wrote graph in file _gfdepgraph.dot"
return void return void
checkComputeTerm os sgr t = checkComputeTerm os sgr0 t =
do mo <- maybe (checkError (pp "no source grammar in scope")) return $ do let (sgr,mo) = case greatestResource sgr0 of
greatestResource sgr Nothing -> (mGrammar [predefMod], fst predefMod)
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 sgr t)

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

@@ -1,22 +1,26 @@
{-# LANGUAGE RankNTypes, CPP #-} {-# LANGUAGE RankNTypes, BangPatterns, CPP #-}
-- | 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
, Value(..), Thunk, ThunkState(..), Env, showValue , Value(..), Thunk, ThunkState(..), Env, Scope, showValue
, EvalM, runEvalM, evalError , MetaThunks, Constraint
, EvalM(..), runEvalM, runEvalOneM, evalError, evalWarn
, eval, apply, force, value2term, patternMatch , eval, apply, force, value2term, patternMatch
, newThunk, newEvaluatedThunk , newThunk, newEvaluatedThunk
, newResiduation, newNarrowing, getVariables , newResiduation, newNarrowing, getVariables
, getRef , getRef, setRef
, getResDef, getInfo, getAllParamValues , getResDef, getInfo, getResType, getOverload
, getAllParamValues
) 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(lookupResDef,lookupOrigInfo,allParamValues) import GF.Grammar.Lookup(lookupResDef,lookupResType,
lookupOrigInfo,lookupOverloadTypes,
allParamValues)
import GF.Grammar.Predef import GF.Grammar.Predef
import GF.Grammar.Lockfield(lockLabel) import GF.Grammar.Lockfield(lockLabel)
import GF.Grammar.Printer import GF.Grammar.Printer
@@ -44,20 +48,24 @@ normalForm gr t =
mkFV [t] = t mkFV [t] = t
mkFV ts = FV ts mkFV ts = FV ts
type Sigma s = Value s
type Constraint s = Value s
data ThunkState s data ThunkState s
= Unevaluated (Env s) Term = Unevaluated (Env s) Term
| Evaluated (Value s) | Evaluated {-# UNPACK #-} !Int (Value s)
| Residuation {-# UNPACK #-} !MetaId | Hole {-# UNPACK #-} !MetaId
| Narrowing {-# UNPACK #-} !MetaId Type | Narrowing {-# UNPACK #-} !MetaId Type
| Residuation {-# UNPACK #-} !MetaId (Scope s) (Maybe (Constraint s))
type Thunk s = STRef s (ThunkState s) type Thunk s = STRef s (ThunkState s)
type Env s = [(Ident,Thunk s)] type Env s = [(Ident,Thunk s)]
type Scope s = [(Ident,Value s)]
data Value s data Value s
= VApp QIdent [Thunk s] = VApp QIdent [Thunk s]
| VMeta (Thunk s) (Env s) [Thunk s] | VMeta (Thunk s) [Thunk s]
| VSusp (Thunk s) (Env s) (Value s -> EvalM s (Value s)) [Thunk s] | VSusp (Thunk s) (Value s -> EvalM s (Value s)) [Thunk s]
| VGen {-# UNPACK #-} !Int [Thunk s] | VGen {-# UNPACK #-} !Int [Thunk s]
| VClosure (Env s) Term | VClosure (Env s) Term
| VProd BindType Ident (Value s) (Value s) | VProd BindType Ident (Value s) (Value s)
@@ -80,27 +88,31 @@ data Value s
| VPattType (Value s) | VPattType (Value s)
| VAlts (Value s) [(Value s, Value s)] | VAlts (Value s) [(Value s, Value s)]
| VStrs [Value s] | VStrs [Value s]
-- These last constructors are only generated internally -- These two constructors are only used internally
-- in the PMCFG generator. -- in the PMCFG generator.
| VSymCat Int LIndex [(LIndex, (Thunk s, Type))] | VSymCat Int LIndex [(LIndex, (Thunk s, Type))]
| VSymVar Int Int | VSymVar Int Int
-- These two constructors are only used internally
-- in the type checker.
| VCRecType [(Label, Bool, Constraint s)]
| VCInts (Maybe Integer) (Maybe Integer)
showValue (VApp q tnks) = "(VApp "++unwords (show q : map (const "_") tnks) ++ ")" showValue (VApp q tnks) = "(VApp "++unwords (show q : map (const "_") tnks) ++ ")"
showValue (VMeta _ _ _) = "VMeta" showValue (VMeta _ _) = "VMeta"
showValue (VSusp _ _ _ _) = "VSusp" showValue (VSusp _ _ _) = "VSusp"
showValue (VGen _ _) = "VGen" showValue (VGen i _) = "(VGen "++show i++")"
showValue (VClosure _ _) = "VClosure" showValue (VClosure _ _) = "VClosure"
showValue (VProd _ _ _ _) = "VProd" showValue (VProd _ x v1 v2) = "VProd ("++show x++") ("++showValue v1++") ("++showValue v2++")"
showValue (VRecType _) = "VRecType" showValue (VRecType _) = "VRecType"
showValue (VR lbls) = "(VR {"++unwords (map (\(lbl,_) -> show lbl) lbls)++"})" showValue (VR lbls) = "(VR {"++unwords (map (\(lbl,_) -> show lbl) lbls)++"})"
showValue (VP v l _) = "(VP "++showValue v++" "++show l++")" showValue (VP v l _) = "(VP "++showValue v++" "++show l++")"
showValue (VExtR _ _) = "VExtR" showValue (VExtR _ _) = "VExtR"
showValue (VTable _ _) = "VTable" showValue (VTable v1 v2) = "VTable ("++showValue v1++") ("++showValue v2++")"
showValue (VT _ _ cs) = "(VT "++show cs++")" showValue (VT _ _ cs) = "(VT "++show cs++")"
showValue (VV _ _) = "VV" showValue (VV _ _) = "VV"
showValue (VS v _ _) = "(VS "++showValue v++")" showValue (VS v _ _) = "(VS "++showValue v++")"
showValue (VSort _) = "VSort" showValue (VSort s) = "(VSort "++show s++")"
showValue (VInt _) = "VInt" showValue (VInt _) = "VInt"
showValue (VFlt _) = "VFlt" showValue (VFlt _) = "VFlt"
showValue (VStr s) = "(VStr "++show s++")" showValue (VStr s) = "(VStr "++show s++")"
@@ -113,11 +125,18 @@ showValue (VAlts _ _) = "VAlts"
showValue (VStrs _) = "VStrs" showValue (VStrs _) = "VStrs"
showValue (VSymCat _ _ _) = "VSymCat" showValue (VSymCat _ _ _) = "VSymCat"
eval env (Vr x) vs = case lookup x env of eval env (Vr x) vs = do (tnk,depth) <- lookup x env
Just tnk -> do v <- force tnk withVar depth $ do
apply v vs v <- force tnk
Nothing -> evalError ("Variable" <+> pp x <+> "is not in scope") apply v vs
eval env (Sort s) [] = return (VSort s) where
lookup x [] = evalError ("Variable" <+> pp x <+> "is not in scope")
lookup x ((y,tnk):env)
| x == y = return (tnk,length env)
| otherwise = lookup x env
eval env (Sort s) []
| s == cTok = return (VSort cStr)
| otherwise = return (VSort s)
eval env (EInt n) [] = return (VInt n) eval env (EInt n) [] = return (VInt n)
eval env (EFloat d) [] = return (VFlt d) eval env (EFloat d) [] = return (VFlt d)
eval env (K t) [] = return (VStr t) eval env (K t) [] = return (VStr t)
@@ -126,8 +145,8 @@ 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))
eval env (Abs b x t) (v:vs) = eval ((x,v):env) t vs eval env (Abs b x t) (v:vs) = eval ((x,v):env) t vs
eval env (Meta i) vs = do tnk <- newResiduation i eval env (Meta i) vs = do tnk <- newHole i
return (VMeta tnk env vs) return (VMeta tnk vs)
eval env (ImplArg t) [] = eval env t [] eval env (ImplArg t) [] = eval env t []
eval env (Prod b x t1 t2)[] = do v1 <- eval env t1 [] eval env (Prod b x t1 t2)[] = do v1 <- eval env t1 []
return (VProd b x v1 (VClosure env t2)) return (VProd b x v1 (VClosure env t2))
@@ -241,8 +260,8 @@ eval env (TSymCat d r rs) []= do rs <- forM rs $ \(i,(pv,ty)) ->
eval env (TSymVar d r) [] = do return (VSymVar d r) eval env (TSymVar d r) [] = do return (VSymVar d r)
eval env t vs = evalError ("Cannot reduce term" <+> pp t) eval env t vs = evalError ("Cannot reduce term" <+> pp t)
apply (VMeta m env vs0) vs = return (VMeta m env (vs0++vs)) apply (VMeta m vs0) vs = return (VMeta m (vs0++vs))
apply (VSusp m env k vs0) vs = return (VSusp m env k (vs0++vs)) apply (VSusp m k vs0) vs = return (VSusp m k (vs0++vs))
apply (VApp f vs0) vs = return (VApp f (vs0++vs)) apply (VApp f vs0) vs = return (VApp f (vs0++vs))
apply (VGen i vs0) vs = return (VGen i (vs0++vs)) 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
@@ -330,9 +349,9 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
match' env p ps eqs arg v args = do match' env p ps eqs arg v args = do
case (p,v) of case (p,v) of
(p, VMeta i envi vs) -> susp i envi (\v -> apply v vs >>= \v -> match' env p ps eqs arg v args) (p, VMeta i vs) -> susp i (\v -> apply v vs >>= \v -> match' env p ps eqs arg v args)
(p, VGen i vs ) -> return v0 (p, VGen i vs) -> return v0
(p, VSusp i envi k vs) -> susp i envi (\v -> k v >>= \v -> apply v vs >>= \v -> match' env p ps eqs arg v args) (p, VSusp i k vs) -> susp i (\v -> k v >>= \v -> apply v vs >>= \v -> match' env p ps eqs arg v args)
(PP q qs, VApp r tnks) (PP q qs, VApp r tnks)
| q == r -> match env (qs++ps) eqs (tnks++args) | q == r -> match env (qs++ps) eqs (tnks++args)
(PR pas, VR as) -> matchRec env (reverse pas) as ps eqs args (PR pas, VR as) -> matchRec env (reverse pas) as ps eqs args
@@ -428,41 +447,41 @@ vtableSelect v0 ty tnks tnk2 vs = do
return (r*cnt'+r',cnt*cnt') return (r*cnt'+r',cnt*cnt')
value2index (VInt n) ty value2index (VInt n) ty
| Just max <- isTypeInts ty = return (fromIntegral n,fromIntegral max+1) | Just max <- isTypeInts ty = return (fromIntegral n,fromIntegral max+1)
value2index (VMeta i envi vs) ty = do value2index (VMeta i vs) ty = do
v <- susp i envi (\v -> apply v vs) v <- susp i (\v -> apply v vs)
value2index v ty value2index v ty
value2index (VSusp i envi k vs) ty = do value2index (VSusp i k vs) ty = do
v <- susp i envi (\v -> k v >>= \v -> apply v vs) v <- susp i (\v -> k v >>= \v -> apply v vs)
value2index v ty value2index v ty
value2index v ty = do t <- value2term [] v value2index v ty = do t <- value2term [] v
evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$ evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
"cannot be evaluated at compile time.") "cannot be evaluated at compile time.")
susp i env ki = EvalM $ \gr k mt r -> do susp i ki = EvalM $ \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 r s m ps Ok (m,ResParam (Just (L _ ps)) _) -> bindParam gr k mt d r msgs s m ps
Bad msg -> return (Fail (pp msg)) 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 r s 0 max -> bindInt gr 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 r EvalM f -> f gr k mt d r msgs
_ -> k (VSusp i env ki []) mt r _ -> k (VSusp i ki []) mt d r msgs
where where
bindParam gr k mt r s m [] = return (Success r) bindParam gr k mt d r msgs s m [] = return (Success r msgs)
bindParam gr k mt r s m ((p, ctxt):ps) = do bindParam gr k mt d r msgs s m ((p, ctxt):ps) = do
(mt',tnks) <- mkArgs mt ctxt (mt',tnks) <- mkArgs mt ctxt
let v = VApp (m,p) tnks let v = VApp (m,p) tnks
writeSTRef i (Evaluated v) writeSTRef i (Evaluated 0 v)
res <- case ki v of res <- case ki v of
EvalM f -> f gr k mt' r EvalM f -> f gr k mt' d r msgs
writeSTRef i s writeSTRef i s
case res of case res of
Fail msg -> return (Fail msg) Fail msg msgs -> return (Fail msg msgs)
Success r -> bindParam gr k mt r s m ps Success r msgs -> bindParam gr k mt d r msgs s m ps
mkArgs mt [] = return (mt,[]) mkArgs mt [] = return (mt,[])
mkArgs mt ((_,_,ty):ctxt) = do mkArgs mt ((_,_,ty):ctxt) = do
@@ -473,56 +492,67 @@ susp i env ki = EvalM $ \gr k mt r -> do
(mt,tnks) <- mkArgs (Map.insert i tnk mt) ctxt (mt,tnks) <- mkArgs (Map.insert i tnk mt) ctxt
return (mt,tnk:tnks) return (mt,tnk:tnks)
bindInt gr k mt r s iv max bindInt gr k mt d r msgs s iv max
| iv <= max = do | iv <= max = do
let v = VInt iv let v = VInt iv
writeSTRef i (Evaluated v) writeSTRef i (Evaluated 0 v)
res <- case ki v of res <- case ki v of
EvalM f -> f gr k mt r EvalM f -> f gr k mt d r msgs
writeSTRef i s writeSTRef i s
case res of case res of
Fail msg -> return (Fail msg) Fail msg msgs -> return (Fail msg msgs)
Success r -> bindInt gr k mt r s (iv+1) max Success r msgs -> bindInt gr k mt d r msgs s (iv+1) max
| otherwise = return (Success r) | otherwise = return (Success r msgs)
value2term xs (VApp q tnks) = value2term xs (VApp q tnks) =
foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (if fst q == cPredef then Q q else QC q) tnks foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (if fst q == cPredef then Q q else QC q) tnks
value2term xs (VMeta m env tnks) = do value2term xs (VMeta m vs) = do
res <- zonk m tnks s <- getRef m
case res of case s of
Right i -> foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (Meta i) tnks Evaluated _ v -> do v <- apply v vs
Left v -> value2term xs v value2term xs v
value2term xs (VSusp j env k vs) = do Unevaluated env t -> do v <- eval env t vs
value2term xs v
Hole i -> foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (Meta i) vs
Residuation i _ ctr -> case ctr of
Just ctr -> value2term xs ctr
Nothing -> foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (Meta i) vs
Narrowing i _ -> foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (Meta i) vs
value2term xs (VSusp j k vs) = do
v <- k (VGen maxBound vs) v <- k (VGen maxBound vs)
value2term xs v value2term xs v
value2term xs (VGen j tnks) = value2term xs (VGen j tnks) =
foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (Vr (reverse xs !! j)) tnks foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (Vr (reverse xs !! j)) tnks
value2term xs (VClosure env (Abs b x t)) = do value2term xs (VClosure env (Abs b x t)) = do
tnk <- newEvaluatedThunk (VGen (length xs) []) tnk <- newEvaluatedThunk (VGen (length xs) [])
v <- eval ((x,tnk):env) t [] v <- eval ((x,tnk):env) t []
let x' = mkFreshVar xs x let x' = mkFreshVar xs x
t <- value2term (x':xs) v t <- value2term (x':xs) v
return (Abs b x' t) return (Abs b x' t)
value2term xs (VProd b x v1 (VClosure env t2)) value2term xs (VProd b x v1 v2)
| x == identW = do t1 <- value2term xs v1 | x == identW = do t1 <- value2term xs v1
v2 <- eval env t2 [] v2 <- case v2 of
VClosure env t2 -> eval env t2 []
v2 -> return v2
t2 <- value2term xs v2 t2 <- value2term xs v2
return (Prod b x t1 t2) return (Prod b x t1 t2)
| otherwise = do t1 <- value2term xs v1 | otherwise = do t1 <- value2term xs v1
tnk <- newEvaluatedThunk (VGen (length xs) []) tnk <- newEvaluatedThunk (VGen (length xs) [])
v2 <- eval ((x,tnk):env) t2 [] v2 <- case v2 of
VClosure env t2 -> eval ((x,tnk):env) t2 []
v2 -> return v2
t2 <- value2term (x:xs) v2 t2 <- value2term (x:xs) v2
return (Prod b (mkFreshVar xs x) t1 t2) return (Prod b (mkFreshVar xs x) t1 t2)
value2term xs (VRecType lbls) = do value2term xs (VRecType lbls) = do
lbls <- mapM (\(lbl,v) -> fmap ((,) lbl) (value2term xs v)) lbls lbls <- mapM (\(lbl,v) -> fmap ((,) lbl) (value2term xs v)) lbls
return (RecType lbls) return (RecType lbls)
value2term xs (VR as) = do value2term xs (VR as) = do
as <- mapM (\(lbl,tnk) -> fmap (\t -> (lbl,(Nothing,t))) (force tnk >>= value2term xs)) as as <- mapM (\(lbl,tnk) -> fmap (\t -> (lbl,(Nothing,t))) (tnk2term xs tnk)) as
return (R as) return (R as)
value2term xs (VP v lbl tnks) = do value2term xs (VP v lbl tnks) = do
t <- value2term xs v t <- value2term xs v
foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (P t lbl) tnks foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (P t lbl) tnks
value2term xs (VExtR v1 v2) = do value2term xs (VExtR v1 v2) = do
t1 <- value2term xs v1 t1 <- value2term xs v1
t2 <- value2term xs v2 t2 <- value2term xs v2
@@ -540,11 +570,11 @@ value2term xs (VT vty env cs)= do
return (p,t) return (p,t)
return (T (TTyped ty) cs) return (T (TTyped ty) cs)
value2term xs (VV vty tnks)= do ty <- value2term xs vty value2term xs (VV vty tnks)= do ty <- value2term xs vty
ts <- mapM (\tnk -> force tnk >>= value2term xs) tnks ts <- mapM (tnk2term xs) tnks
return (V ty ts) return (V ty ts)
value2term xs (VS v1 tnk2 tnks) = do t1 <- value2term xs v1 value2term xs (VS v1 tnk2 tnks) = do t1 <- value2term xs v1
t2 <- force tnk2 >>= value2term xs t2 <- tnk2term xs tnk2
foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (S t1 t2) tnks foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (S t1 t2) tnks
value2term xs (VSort s) = return (Sort s) value2term xs (VSort s) = return (Sort s)
value2term xs (VStr tok) = return (K tok) value2term xs (VStr tok) = return (K tok)
value2term xs (VInt n) = return (EInt n) value2term xs (VInt n) = return (EInt n)
@@ -571,6 +601,12 @@ value2term xs (VAlts vd vas) = do
value2term xs (VStrs vs) = do value2term xs (VStrs vs) = do
ts <- mapM (value2term xs) vs ts <- mapM (value2term xs) vs
return (Strs ts) return (Strs ts)
value2term xs (VCInts (Just i) Nothing) = return (App (Q (cPredef,cInts)) (EInt i))
value2term xs (VCInts Nothing (Just j)) = return (App (Q (cPredef,cInts)) (EInt j))
value2term xs (VCRecType lctrs) = do
ltys <- mapM (\(l,o,ctr) -> value2term xs ctr >>= \ty -> return (l,ty)) lctrs
return (RecType ltys)
value2term xs v = error (showValue v)
pattVars st (PP _ ps) = foldM pattVars st ps pattVars st (PP _ ps) = foldM pattVars st ps
pattVars st (PV x) = case st of pattVars st (PV x) = case st of
@@ -675,7 +711,7 @@ value2int _ = RunTime
-- * Evaluation monad -- * Evaluation monad
type MetaThunks s = Map.Map MetaId (Thunk s) type MetaThunks s = Map.Map MetaId (Thunk s)
type Cont s r = MetaThunks s -> r -> ST s (CheckResult r) 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) newtype EvalM s a = EvalM (forall r . Grammar -> (a -> Cont s r) -> Cont s r)
instance Functor (EvalM s) where instance Functor (EvalM s) where
@@ -694,76 +730,114 @@ instance Monad (EvalM s) where
#endif #endif
instance Fail.MonadFail (EvalM s) where instance Fail.MonadFail (EvalM s) where
fail msg = EvalM (\gr k _ r -> return (Fail (pp msg))) fail msg = EvalM (\gr k _ _ r msgs -> return (Fail (pp msg) msgs))
instance Alternative (EvalM s) where instance Alternative (EvalM s) where
empty = EvalM (\gr k _ r -> return (Success r)) empty = EvalM (\gr k _ _ r msgs -> return (Success r msgs))
(EvalM f) <|> (EvalM g) = EvalM $ \gr k mt r -> do (EvalM f) <|> (EvalM g) = EvalM $ \gr k mt b r msgs -> do
res <- f gr k mt r res <- f gr k mt b r msgs
case res of case res of
Fail msg -> return (Fail msg) Fail msg msgs -> return (Fail msg msgs)
Success r -> g gr k mt r Success r msgs -> g gr k mt b r msgs
instance MonadPlus (EvalM s) where instance MonadPlus (EvalM s) where
runEvalM :: Grammar -> (forall s . EvalM s a) -> Check [a] runEvalM :: Grammar -> (forall s . EvalM s a) -> Check [a]
runEvalM gr f = runEvalM gr f = Check $ \(es,ws) ->
case runST (case f of case runST (case f of
EvalM f -> f gr (\x mt xs -> return (Success (x:xs))) Map.empty []) of EvalM f -> f gr (\x mt _ xs ws -> return (Success (x:xs) ws)) Map.empty maxBound [] ws) of
Fail msg -> checkError msg Fail msg ws -> Fail msg (es,ws)
Success xs -> return (reverse xs) Success xs ws -> Success (reverse xs) (es,ws)
evalError :: Doc -> EvalM s a runEvalOneM :: Grammar -> (forall s . EvalM s a) -> Check a
evalError msg = EvalM (\gr k _ r -> return (Fail msg)) 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
Fail msg ws -> Fail msg (es,ws)
Success [] ws -> Fail (pp "The evaluation produced no results") (es,ws)
Success (x:_) ws -> Success x (es,ws)
evalError :: Message -> EvalM s a
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))
getResDef :: QIdent -> EvalM s Term getResDef :: QIdent -> EvalM s Term
getResDef q = EvalM $ \gr k mt r -> do getResDef q = EvalM $ \gr k mt d r msgs -> do
case lookupResDef gr q of case lookupResDef gr q of
Ok t -> k t mt r Ok t -> k t mt d r msgs
Bad msg -> return (Fail (pp msg)) 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 r -> do getInfo q = EvalM $ \gr k mt d r msgs -> do
case lookupOrigInfo gr q of case lookupOrigInfo gr q of
Ok res -> k res mt r Ok res -> k res mt d r msgs
Bad msg -> return (Fail (pp msg)) Bad msg -> return (Fail (pp msg) msgs)
getResType :: QIdent -> EvalM s Type
getResType q = EvalM $ \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
case lookupOverloadTypes gr q of
Ok ttys -> let err = "Overload resolution failed" $$
"of term " <+> pp t $$
"with types" <+> vcat [ppTerm Terse 0 ty | (_,ty) <- ttys]
go [] = return (Fail err msgs)
go (tty:ttys) = do res <- k tty mt d r msgs
case res of
Fail _ _ -> return res -- go ttys
Success r msgs -> return (Success r msgs)
in go ttys
Bad msg -> return (Fail (pp msg) msgs)
getAllParamValues :: Type -> EvalM s [Term] getAllParamValues :: Type -> EvalM s [Term]
getAllParamValues ty = EvalM $ \gr k mt r -> getAllParamValues ty = EvalM $ \gr k mt d r msgs ->
case allParamValues gr ty of case allParamValues gr ty of
Ok ts -> k ts mt r Ok ts -> k ts mt d r msgs
Bad msg -> return (Fail (pp msg)) Bad msg -> return (Fail (pp msg) msgs)
newThunk env t = EvalM $ \gr k mt r -> do newThunk env t = EvalM $ \gr k mt d r msgs -> do
tnk <- newSTRef (Unevaluated env t) tnk <- newSTRef (Unevaluated env t)
k tnk mt r k tnk mt d r msgs
newEvaluatedThunk v = EvalM $ \gr k mt r -> do newEvaluatedThunk v = EvalM $ \gr k mt d r msgs -> do
tnk <- newSTRef (Evaluated v) tnk <- newSTRef (Evaluated maxBound v)
k tnk mt r k tnk mt d r msgs
newResiduation i = EvalM $ \gr k mt r -> newHole i = EvalM $ \gr k mt d r msgs ->
if i == 0 if i == 0
then do tnk <- newSTRef (Residuation i) then do tnk <- newSTRef (Hole i)
k tnk mt r k tnk mt d r msgs
else case Map.lookup i mt of else case Map.lookup i mt of
Just tnk -> k tnk mt r Just tnk -> k tnk mt d r msgs
Nothing -> do tnk <- newSTRef (Residuation i) Nothing -> do tnk <- newSTRef (Hole i)
k tnk (Map.insert i tnk mt) r k tnk (Map.insert i tnk mt) d r msgs
newNarrowing i ty = EvalM $ \gr k mt r -> newResiduation scope = EvalM $ \gr k mt d r msgs -> do
if i == 0 let i = Map.size mt + 1
then do tnk <- newSTRef (Narrowing i ty) tnk <- newSTRef (Residuation i scope Nothing)
k tnk mt r k (i,tnk) (Map.insert i tnk mt) d r msgs
else case Map.lookup i mt of
Just tnk -> k tnk mt r newNarrowing ty = EvalM $ \gr k mt d r msgs -> do
Nothing -> do tnk <- newSTRef (Narrowing i ty) let i = Map.size mt + 1
k tnk (Map.insert i tnk mt) r tnk <- newSTRef (Narrowing i ty)
k (i,tnk) (Map.insert i tnk mt) d r msgs
withVar d0 (EvalM f) = EvalM $ \gr k mt d1 r msgs ->
let !d = min d0 d1
in f gr k mt d r msgs
getVariables :: EvalM s [(LVar,LIndex)] getVariables :: EvalM s [(LVar,LIndex)]
getVariables = EvalM $ \gr k mt r -> do getVariables = EvalM $ \gr k mt d ws r -> do
ps <- metas2params gr (Map.elems mt) ps <- metas2params gr (Map.elems mt)
k ps mt r k ps mt d ws r
where where
metas2params gr [] = return [] metas2params gr [] = return []
metas2params gr (tnk:tnks) = do metas2params gr (tnk:tnks) = do
@@ -778,24 +852,63 @@ getVariables = EvalM $ \gr k mt r -> do
else return params else return params
_ -> metas2params gr tnks _ -> metas2params gr tnks
getRef tnk = EvalM $ \gr k mt r -> readSTRef tnk >>= \st -> k st mt r getRef tnk = EvalM $ \gr k mt d r msgs -> readSTRef tnk >>= \st -> k st mt d r msgs
setRef tnk st = EvalM $ \gr k mt d r msgs -> do
old <- readSTRef tnk
writeSTRef tnk st
res <- k () mt d r msgs
writeSTRef tnk old
return res
force tnk = EvalM $ \gr k mt r -> do force tnk = EvalM $ \gr k mt d r msgs -> do
s <- readSTRef tnk s <- readSTRef tnk
case s of case s of
Unevaluated env t -> case eval env t [] of Unevaluated env t -> case eval env t [] of
EvalM f -> f gr (\v mt r -> do writeSTRef tnk (Evaluated v) EvalM f -> f gr (\v mt b r msgs -> do let d = length env
r <- k v mt r writeSTRef tnk (Evaluated d v)
writeSTRef tnk s r <- k v mt d r msgs
return r) mt r writeSTRef tnk s
Evaluated v -> k v mt r return r) mt d r msgs
Residuation _ -> k (VMeta tnk [] []) mt r Evaluated d v -> k v mt d r msgs
Narrowing _ _ -> k (VMeta tnk [] []) mt r Hole _ -> k (VMeta tnk []) mt d r msgs
Residuation _ _ _ -> k (VMeta tnk []) mt d r msgs
Narrowing _ _ -> k (VMeta tnk []) mt d r msgs
zonk tnk vs = EvalM $ \gr k mt r -> do tnk2term xs tnk = EvalM $ \gr k mt d r msgs ->
s <- readSTRef tnk let join f g = do res <- f
case s of case res of
Evaluated v -> case apply v vs of Fail msg msgs -> return (Fail msg msgs)
EvalM f -> f gr (k . Left) mt r Success r msgs -> g r msgs
Residuation i -> k (Right i) mt r
Narrowing i _ -> k (Right i) mt r flush [] k1 mt r msgs = k1 mt r msgs
flush [x] k1 mt r msgs = join (k x mt d r msgs) (k1 mt)
flush xs k1 mt r msgs = join (k (FV (reverse xs)) mt d r msgs) (k1 mt)
acc d0 x mt d (r,!c,xs) msgs
| d < d0 = flush xs (\mt r msgs -> join (k x mt d r msgs) (\r msgs -> return (Success (r,c+1,[]) msgs))) mt r msgs
| otherwise = return (Success (r,c+1,x:xs) msgs)
in do s <- readSTRef tnk
case s of
Unevaluated env t -> do let d0 = length env
res <- case eval env t [] of
EvalM f -> f gr (\v mt d msgs r -> do writeSTRef tnk (Evaluated d0 v)
r <- case value2term xs v of
EvalM f -> f gr (acc d0) mt d msgs r
writeSTRef tnk s
return r) mt maxBound (r,0,[]) msgs
case res of
Fail msg msgs -> return (Fail msg msgs)
Success (r,0,xs) msgs -> k (FV []) mt d r msgs
Success (r,c,xs) msgs -> flush xs (\mt msgs r -> return (Success msgs r)) mt r msgs
Evaluated d0 v -> do res <- case value2term xs v of
EvalM f -> f gr (acc d0) mt maxBound (r,0,[]) msgs
case res of
Fail msg msgs -> return (Fail msg msgs)
Success (r,0,xs) msgs -> k (FV []) mt d r msgs
Success (r,c,xs) msgs -> flush xs (\mt r msgs -> return (Success r msgs)) mt r msgs
Hole i -> k (Meta i) mt d r msgs
Residuation 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..]

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

@@ -24,10 +24,12 @@ import GF.Data.Operations(Err(..))
import PGF2.Transactions import PGF2.Transactions
import Control.Monad import Control.Monad
import Control.Monad.State import Control.Monad.State
import Control.Monad.ST
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Data.List(mapAccumL,sortOn,sortBy) import Data.List(mapAccumL,sortOn,sortBy)
import Data.Maybe(fromMaybe,isNothing) import Data.Maybe(fromMaybe,isNothing)
import Data.STRef
generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
generatePMCFG opts cwd gr cmo@(cm,cmi) generatePMCFG opts cwd gr cmo@(cm,cmi)
@@ -77,12 +79,12 @@ 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 gr $ do
((_,ms),args) <- mapAccumM (\(d,ms) (_,_,ty) -> do (_,args) <- mapAccumM (\arg_no (_,_,ty) -> do
let (ms',_,t) = type2metaTerm gr d ms 0 [] ty t <- EvalM (\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 tnk <- newThunk [] t
return ((d+1,ms'),tnk)) return (arg_no+1,tnk))
(0,Map.empty) ctxt 0 ctxt
sequence_ [newNarrowing i ty | (i,ty) <- Map.toList ms]
v <- eval [] t args v <- eval [] t args
(lins,params) <- flatten v ty ([],[]) (lins,params) <- flatten v ty ([],[])
lins <- fmap reverse $ mapM str2lin lins lins <- fmap reverse $ mapM str2lin lins
@@ -116,34 +118,38 @@ pmcfgForm gr t ctxt ty seqs = do
Nothing -> let seqid = Map.size m Nothing -> let seqid = Map.size m
in (seqid,Map.insert lin seqid m) in (seqid,Map.insert lin seqid m)
type2metaTerm :: SourceGrammar -> Int -> Map.Map MetaId Type -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> (Map.Map MetaId Type,Int,Term) type2metaTerm :: SourceGrammar -> Int -> MetaThunks s -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> ST s (MetaThunks s,Int,Term)
type2metaTerm gr d ms r rs (Sort s) | s == cStr = type2metaTerm gr d ms r rs (Sort s) | s == cStr =
(ms,r+1,TSymCat d r rs) return (ms,r+1,TSymCat d r rs)
type2metaTerm gr d ms r rs (RecType lbls) = type2metaTerm gr d ms r rs (RecType lbls) = do
let ((ms',r'),ass) = mapAccumL (\(ms,r) (lbl,ty) -> case lbl of ((ms',r'),ass) <- mapAccumM (\(ms,r) (lbl,ty) -> case lbl of
LVar j -> ((ms,r),(lbl,(Just ty,TSymVar d j))) LVar j -> return ((ms,r),(lbl,(Just ty,TSymVar d j)))
lbl -> let (ms',r',t) = type2metaTerm gr d ms r rs ty lbl -> do (ms',r',t) <- type2metaTerm gr d ms r rs ty
in ((ms',r'),(lbl,(Just ty,t)))) return ((ms',r'),(lbl,(Just ty,t))))
(ms,r) lbls (ms,r) lbls
in (ms',r',R ass) return (ms',r',R ass)
type2metaTerm gr d ms r rs (Table p q) type2metaTerm gr d ms r rs (Table p q)
| count == 1 = let (ms',r',t) = type2metaTerm gr d ms r rs q | count == 1 = do (ms',r',t) <- type2metaTerm gr d ms r rs q
in (ms',r+(r'-r),T (TTyped p) [(PW,t)]) return (ms',r+(r'-r),T (TTyped p) [(PW,t)])
| otherwise = let pv = varX (length rs+1) | otherwise = do let pv = varX (length rs+1)
delta = r'-r (ms',delta,t) <-
(ms',r',t) = type2metaTerm gr d ms r ((delta,(pv,p)):rs) q fixST $ \(~(_,delta,_)) ->
in (ms',r+delta*count,T (TTyped p) [(PV pv,t)]) do (ms',r',t) <- type2metaTerm gr d ms r ((delta,(pv,p)):rs) q
return (ms',r'-r,t)
return (ms',r+delta*count,T (TTyped p) [(PV pv,t)])
where where
count = case allParamValues gr p of count = case allParamValues gr p of
Ok ts -> length ts Ok ts -> length ts
Bad msg -> error msg Bad msg -> error msg
type2metaTerm gr d ms r rs ty@(QC q) = type2metaTerm gr d ms r rs ty@(QC q) = do
let i = Map.size ms + 1 let i = Map.size ms + 1
in (Map.insert i ty ms,r,Meta i) tnk <- newSTRef (Narrowing i ty)
return (Map.insert i tnk ms,r,Meta i)
type2metaTerm gr d ms r rs ty type2metaTerm gr d ms r rs ty
| Just n <- isTypeInts ty = | Just n <- isTypeInts ty = do
let i = Map.size ms + 1 let i = Map.size ms + 1
in (Map.insert i ty ms,r,Meta i) tnk <- newSTRef (Narrowing i ty)
return (Map.insert i tnk ms,r,Meta i)
flatten (VR as) (RecType lbls) st = do flatten (VR as) (RecType lbls) st = do
foldM collect st lbls foldM collect st lbls
@@ -247,10 +253,10 @@ param2int (VApp q tnks) ty = do
return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt') return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
param2int (VInt n) ty param2int (VInt n) ty
| Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1) | Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1)
param2int (VMeta tnk _ _) ty = do param2int (VMeta tnk _) ty = do
tnk_st <- getRef tnk tnk_st <- getRef tnk
case tnk_st of case tnk_st of
Evaluated v -> param2int v ty Evaluated _ v -> param2int v ty
Narrowing j ty -> do ts <- getAllParamValues ty Narrowing j ty -> do ts <- getAllParamValues ty
return (0,[(1,j-1)],length ts) return (0,[(1,j-1)],length ts)
param2int v ty = do t <- value2term [] v param2int v ty = do t <- value2term [] v

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

File diff suppressed because it is too large Load Diff

18
src/compiler/GF/Compile/TypeCheck/Primitives.hs
View File

@@ -1,5 +1,6 @@
module GF.Compile.TypeCheck.Primitives where module GF.Compile.TypeCheck.Primitives(typPredefined,predefMod) where
import GF.Infra.Option
import GF.Grammar import GF.Grammar
import GF.Grammar.Predef import GF.Grammar.Predef
import qualified Data.Map as Map import qualified Data.Map as Map
@@ -11,6 +12,21 @@ typPredefined f = case Map.lookup f primitives of
Just (ResValue (L _ ty) _) -> Just ty Just (ResValue (L _ ty) _) -> Just ty
_ -> Nothing _ -> Nothing
predefMod = (cPredef, modInfo)
where
modInfo = ModInfo {
mtype = MTResource,
mstatus = MSComplete,
mflags = noOptions,
mextend = [],
mwith = Nothing,
mopens = [],
mexdeps = [],
msrc = "Predef.gfo",
mseqs = Nothing,
jments = primitives
}
primitives = Map.fromList primitives = Map.fromList
[ (cErrorType, ResOper (Just (noLoc typeType)) Nothing) [ (cErrorType, ResOper (Just (noLoc typeType)) Nothing)
, (cInt , ResOper (Just (noLoc typePType)) Nothing) , (cInt , ResOper (Just (noLoc typePType)) Nothing)

2
src/compiler/GF/Grammar/Parser.y
View File

@@ -31,7 +31,7 @@ import qualified Data.Map as Map
%name pModDef ModDef %name pModDef ModDef
%name pTopDef TopDef %name pTopDef TopDef
%partial pModHeader ModHeader %partial pModHeader ModHeader
%partial pTerm Exp1 %partial pTerm Exp
%name pExp Exp %name pExp Exp
%name pBNFCRules ListCFRule %name pBNFCRules ListCFRule
%name pEBNFRules ListEBNFRule %name pEBNFRules ListEBNFRule

60
src/compiler/GF/Infra/CheckM.hs
View File

@@ -13,7 +13,7 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Infra.CheckM module GF.Infra.CheckM
(Check, CheckResult(..), Message, runCheck, runCheck', (Check(..), CheckResult(..), Message, runCheck, runCheck',
checkError, checkCond, checkWarn, checkWarnings, checkAccumError, checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
checkIn, checkInModule, checkMap, checkMapRecover, checkIn, checkInModule, checkMap, checkMapRecover,
accumulateError, commitCheck, accumulateError, commitCheck,
@@ -37,22 +37,19 @@ import qualified Control.Monad.Fail as Fail
type Message = Doc type Message = Doc
type Error = Message type Error = Message
type Warning = Message type Warning = Message
--data Severity = Warning | Error
--type NonFatal = ([Severity,Message]) -- preserves order
type NonFatal = ([Error],[Warning]) type NonFatal = ([Error],[Warning])
type Accumulate acc ans = acc -> (acc,ans) data CheckResult a b = Fail Error b | Success a b
data CheckResult a = Fail Error | Success a
newtype Check a newtype Check a
= Check {unCheck :: {-Context ->-} Accumulate NonFatal (CheckResult a)} = Check {unCheck :: NonFatal -> CheckResult a NonFatal}
instance Functor Check where fmap = liftM instance Functor Check where fmap = liftM
instance Monad Check where instance Monad Check where
return x = Check $ \{-ctxt-} ws -> (ws,Success x) return x = Check $ \msgs -> Success x msgs
f >>= g = Check $ \{-ctxt-} ws -> f >>= g = Check $ \ws ->
case unCheck f {-ctxt-} ws of case unCheck f ws of
(ws,Success x) -> unCheck (g x) {-ctxt-} ws Success x msgs -> unCheck (g x) msgs
(ws,Fail msg) -> (ws,Fail msg) Fail msg msgs -> Fail msg msgs
instance Fail.MonadFail Check where instance Fail.MonadFail Check where
fail = raise fail = raise
@@ -65,26 +62,26 @@ instance ErrorMonad Check where
raise s = checkError (pp s) raise s = checkError (pp s)
handle f h = handle' f (h . render) handle f h = handle' f (h . render)
handle' f h = Check (\{-ctxt-} msgs -> case unCheck f {-ctxt-} msgs of handle' f h = Check (\msgs -> case unCheck f {-ctxt-} msgs of
(ws,Success x) -> (ws,Success x) Success x msgs -> Success x msgs
(ws,Fail msg) -> unCheck (h msg) {-ctxt-} ws) Fail msg msgs -> unCheck (h msg) msgs)
-- | Report a fatal error -- | Report a fatal error
checkError :: Message -> Check a checkError :: Message -> Check a
checkError msg = Check (\{-ctxt-} ws -> (ws,Fail msg)) checkError msg = Check (\msgs -> Fail msg msgs)
checkCond :: Message -> Bool -> Check () checkCond :: Message -> Bool -> Check ()
checkCond s b = if b then return () else checkError s checkCond s b = if b then return () else checkError s
-- | warnings should be reversed in the end -- | warnings should be reversed in the end
checkWarn :: Message -> Check () checkWarn :: Message -> Check ()
checkWarn msg = Check $ \{-ctxt-} (es,ws) -> ((es,("Warning:" <+> msg) : ws),Success ()) checkWarn msg = Check $ \(es,ws) -> Success () (es,("Warning:" <+> msg) : ws)
checkWarnings ms = mapM_ checkWarn ms checkWarnings ms = mapM_ checkWarn ms
-- | Report a nonfatal (accumulated) error -- | Report a nonfatal (accumulated) error
checkAccumError :: Message -> Check () checkAccumError :: Message -> Check ()
checkAccumError msg = Check $ \{-ctxt-} (es,ws) -> ((msg:es,ws),Success ()) checkAccumError msg = Check $ \(es,ws) -> Success () (msg:es,ws)
-- | Turn a fatal error into a nonfatal (accumulated) error -- | Turn a fatal error into a nonfatal (accumulated) error
accumulateError :: (a -> Check a) -> a -> Check a accumulateError :: (a -> Check a) -> a -> Check a
@@ -94,13 +91,13 @@ accumulateError chk a =
-- | Turn accumulated errors into a fatal error -- | Turn accumulated errors into a fatal error
commitCheck :: Check a -> Check a commitCheck :: Check a -> Check a
commitCheck c = commitCheck c =
Check $ \ {-ctxt-} msgs0@(es0,ws0) -> Check $ \msgs0@(es0,ws0) ->
case unCheck c {-ctxt-} ([],[]) of case unCheck c ([],[]) of
(([],ws),Success v) -> ((es0,ws++ws0),Success v) (Success v ([],ws)) -> Success v (es0,ws++ws0)
(msgs ,Success _) -> bad msgs0 msgs (Success _ msgs) -> bad msgs0 msgs
((es,ws),Fail e) -> bad msgs0 ((e:es),ws) (Fail e (es,ws)) -> bad msgs0 ((e:es),ws)
where where
bad (es0,ws0) (es,ws) = ((es0,ws++ws0),Fail (list es)) bad (es0,ws0) (es,ws) = (Fail (list es) (es0,ws++ws0))
list = vcat . reverse list = vcat . reverse
-- | Run an error check, report errors and warnings -- | Run an error check, report errors and warnings
@@ -109,10 +106,10 @@ runCheck c = runCheck' noOptions c
-- | Run an error check, report errors and (optionally) warnings -- | Run an error check, report errors and (optionally) warnings
runCheck' :: ErrorMonad m => Options -> Check a -> m (a,String) runCheck' :: ErrorMonad m => Options -> Check a -> m (a,String)
runCheck' opts c = runCheck' opts c =
case unCheck c {-[]-} ([],[]) of case unCheck c ([],[]) of
(([],ws),Success v) -> return (v,render (wlist ws)) Success v ([],ws) -> return (v,render (wlist ws))
(msgs ,Success v) -> bad msgs Success v msgs -> bad msgs
((es,ws),Fail e) -> bad ((e:es),ws) Fail e (es,ws) -> bad ((e:es),ws)
where where
bad (es,ws) = raise (render $ wlist ws $$ list es) bad (es,ws) = raise (render $ wlist ws $$ list es)
list = vcat . reverse list = vcat . reverse
@@ -128,12 +125,13 @@ checkMapRecover f = fmap Map.fromList . mapM f' . Map.toList
where f' (k,v) = fmap ((,)k) (f k v) where f' (k,v) = fmap ((,)k) (f k v)
checkIn :: Doc -> Check a -> Check a checkIn :: Doc -> Check a -> Check a
checkIn msg c = Check $ \{-ctxt-} msgs0 -> checkIn msg c = Check $ \msgs0 ->
case unCheck c {-ctxt-} ([],[]) of case unCheck c ([],[]) of
(msgs,Fail msg) -> (augment msgs0 msgs,Fail (augment1 msg)) Fail msg msgs -> Fail (augment1 msg) (augment msgs0 msgs)
(msgs,Success v) -> (augment msgs0 msgs,Success v) Success v msgs -> Success v (augment msgs0 msgs)
where where
augment (es0,ws0) (es,ws) = (augment' es0 es,augment' ws0 ws) augment (es0,ws0) (es,ws) = (augment' es0 es,augment' ws0 ws)
augment' msgs0 [] = msgs0 augment' msgs0 [] = msgs0
augment' msgs0 msgs' = (msg $$ nest 3 (vcat (reverse msgs'))):msgs0 augment' msgs0 msgs' = (msg $$ nest 3 (vcat (reverse msgs'))):msgs0

15
src/compiler/GF/Interactive.hs
View File

@@ -14,6 +14,7 @@ import GF.Command.Abstract
import GF.Command.Parse(readCommandLine,pCommand,readTransactionCommand) import GF.Command.Parse(readCommandLine,pCommand,readTransactionCommand)
import GF.Compile.Rename(renameSourceTerm) import GF.Compile.Rename(renameSourceTerm)
import GF.Compile.TypeCheck.Concrete(inferLType) import GF.Compile.TypeCheck.Concrete(inferLType)
import GF.Compile.TypeCheck.Primitives(predefMod)
import GF.Compile.GeneratePMCFG(pmcfgForm,type2fields) import GF.Compile.GeneratePMCFG(pmcfgForm,type2fields)
import GF.Data.Operations (Err(..)) import GF.Data.Operations (Err(..))
import GF.Data.Utilities(whenM,repeatM) import GF.Data.Utilities(whenM,repeatM)
@@ -283,10 +284,11 @@ transactionCommand (CreateConcrete opts name) pgf mb_txnid = do
lift $ updatePGF pgf mb_txnid (createConcrete name (return ())) lift $ updatePGF pgf mb_txnid (createConcrete name (return ()))
return () return ()
transactionCommand (CreateLin opts f t is_alter) pgf mb_txnid = do transactionCommand (CreateLin opts f t is_alter) pgf mb_txnid = do
sgr <- getGrammar sgr0 <- getGrammar
let (sgr,mo) = case greatestResource sgr0 of
Nothing -> (mGrammar [predefMod], fst predefMod)
Just mo -> (sgr0,mo)
lang <- optLang pgf opts lang <- optLang pgf opts
mo <- maybe (fail "no source grammar in scope") return $
greatestResource sgr
lift $ updatePGF pgf mb_txnid $ do lift $ updatePGF pgf mb_txnid $ do
mb_ty <- getFunctionType f mb_ty <- getFunctionType f
case mb_ty of case mb_ty of
@@ -319,10 +321,11 @@ transactionCommand (CreateLin opts f t is_alter) pgf mb_txnid = do
mapToSequence m = Seq.fromList (map (Left . fst) (sortOn snd (Map.toList m))) mapToSequence m = Seq.fromList (map (Left . fst) (sortOn snd (Map.toList m)))
transactionCommand (CreateLincat opts c t) pgf mb_txnid = do transactionCommand (CreateLincat opts c t) pgf mb_txnid = do
sgr <- getGrammar sgr0 <- getGrammar
let (sgr,mo) = case greatestResource sgr0 of
Nothing -> (mGrammar [predefMod], fst predefMod)
Just mo -> (sgr0,mo)
lang <- optLang pgf opts lang <- optLang pgf opts
mo <- maybe (fail "no source grammar in scope") return $
greatestResource sgr
case runCheck (compileLincatTerm sgr mo t) of case runCheck (compileLincatTerm sgr mo t) of
Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] Seq.empty >> return ())) Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] Seq.empty >> return ()))
return () return ()

54
src/runtime/c/pgf/phrasetable.cxx
View File

@@ -474,16 +474,12 @@ PgfPhrasetable phrasetable_delete(PgfPhrasetable table,
PgfPhrasetable left = phrasetable_delete(table->left, PgfPhrasetable left = phrasetable_delete(table->left,
container, seq_index, container, seq_index,
seq); seq);
if (left == table->left)
return table;
table = Node<PgfPhrasetableEntry>::upd_node(table,left,table->right); table = Node<PgfPhrasetableEntry>::upd_node(table,left,table->right);
return Node<PgfPhrasetableEntry>::balanceR(table); return Node<PgfPhrasetableEntry>::balanceR(table);
} else if (cmp > 0) { } else if (cmp > 0) {
PgfPhrasetable right = phrasetable_delete(table->right, PgfPhrasetable right = phrasetable_delete(table->right,
container, seq_index, container, seq_index,
seq); seq);
if (right == table->right)
return table;
table = Node<PgfPhrasetableEntry>::upd_node(table,table->left,right); table = Node<PgfPhrasetableEntry>::upd_node(table,table->left,right);
return Node<PgfPhrasetableEntry>::balanceL(table); return Node<PgfPhrasetableEntry>::balanceL(table);
} else { } else {
@@ -821,56 +817,6 @@ void phrasetable_lookup_cohorts(PgfPhrasetable table,
} }
} }
PGF_INTERNAL
void phrasetable_lookup_epsilons(PgfPhrasetable table,
ref<PgfConcrLincat> lincat, size_t r,
std::function<void(ref<PgfConcrLin>,size_t)> &f)
{
while (table->left != 0) {
table = table->left;
}
if (table->value.seq->syms.len > 0)
return;
size_t len = (table->value.backrefs != 0)
? table->value.backrefs->len
: 0;
ssize_t i = 0;
ssize_t j = len-1;
while (i <= j) {
ssize_t k = (i + j) / 2;
ref<PgfSequenceBackref> backref = vector_elem(table->value.backrefs, k);
int cmp = backref_cmp(backref, lincat, r);
if (cmp < 0) {
j = k-1;
} else if (cmp > 0) {
i = k+1;
} else {
i = k;
while (i > 0) {
ref<PgfSequenceBackref> backref = vector_elem(table->value.backrefs, i-1);
if (backref_cmp(backref, lincat, r) != 0)
break;
f(ref<PgfConcrLin>::untagged(backref->container),backref->seq_index);
i--;
}
f(ref<PgfConcrLin>::untagged(backref->container),backref->seq_index);
j = k;
while (j < len-1) {
ref<PgfSequenceBackref> backref = vector_elem(table->value.backrefs, j+1);
if (backref_cmp(backref, lincat, r) != 0)
break;
f(ref<PgfConcrLin>::untagged(backref->container),backref->seq_index);
j++;
}
break;
}
}
}
PGF_INTERNAL PGF_INTERNAL
void phrasetable_iter(PgfConcr *concr, void phrasetable_iter(PgfConcr *concr,
PgfPhrasetable table, PgfPhrasetable table,

5
src/runtime/c/pgf/phrasetable.h
View File

@@ -105,11 +105,6 @@ void phrasetable_lookup_cohorts(PgfPhrasetable table,
bool case_sensitive, bool case_sensitive,
PgfPhraseScanner *scanner, PgfExn* err); PgfPhraseScanner *scanner, PgfExn* err);
PGF_INTERNAL_DECL
void phrasetable_lookup_epsilons(PgfPhrasetable table,
ref<PgfConcrLincat> lincat, size_t r,
std::function<void(ref<PgfConcrLin>, size_t)> &f);
PGF_INTERNAL_DECL PGF_INTERNAL_DECL
void phrasetable_iter(PgfConcr *concr, void phrasetable_iter(PgfConcr *concr,
PgfPhrasetable table, PgfPhrasetable table,