mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-08-19 10:46:22 -06:00
Merge branch 'majestic' of github.com:krangelov/gf-core into majestic
This commit is contained in:
Krasimir Angelov
@@ -3,7 +3,7 @@
|
||||
module GF.Compile.Compute.Concrete2
|
||||
(Env, Scope, Value(..), Variants(..), OptionInfo(..),
|
||||
ConstValue(..), Globals(..), PredefTable, EvalM,
|
||||
mapVariants, mapVariantsC, unvariants,
|
||||
mapVariantsC, unvariants,
|
||||
runEvalM, runEvalMWithInput, stdPredef, globals,
|
||||
PredefImpl, Predef(..), ($\),
|
||||
pdCanonicalArgs, pdArity,
|
||||
@@ -97,9 +97,9 @@ data Variants a
|
||||
= VarFree [a]
|
||||
| VarOpts Value [(Value, a)]
|
||||
|
||||
mapVariants :: (a -> b) -> Variants a -> Variants b
|
||||
mapVariants f (VarFree vs) = VarFree (f <$> vs)
|
||||
mapVariants f (VarOpts n cs) = VarOpts n (second f <$> cs)
|
||||
instance Functor Variants where
|
||||
fmap f (VarFree vs) = VarFree (f <$> vs)
|
||||
fmap f (VarOpts n cs) = VarOpts n (second f <$> cs)
|
||||
|
||||
mapVariantsC :: (Choice -> a -> b) -> Choice -> Variants a -> Variants b
|
||||
mapVariantsC f c (VarFree vs) = VarFree (mapC f c vs)
|
||||
@@ -139,7 +139,7 @@ data ConstValue a
|
||||
|
||||
instance Functor ConstValue where
|
||||
fmap f (Const c) = Const (f c)
|
||||
fmap f (CFV i vs) = CFV i (mapVariants (fmap f) vs)
|
||||
fmap f (CFV i vs) = CFV i (fmap (fmap f) vs)
|
||||
fmap f (CSusp i k) = CSusp i (fmap f . k)
|
||||
fmap f RunTime = RunTime
|
||||
fmap f NonExist = NonExist
|
||||
@@ -148,8 +148,8 @@ instance Applicative ConstValue where
|
||||
pure = Const
|
||||
|
||||
(Const f) <*> (Const x) = Const (f x)
|
||||
(CFV s vs) <*> v2 = CFV s (mapVariants (<*> v2) vs)
|
||||
v1 <*> (CFV s vs) = CFV s (mapVariants (v1 <*>) vs)
|
||||
(CFV s vs) <*> v2 = CFV s (fmap (<*> v2) vs)
|
||||
v1 <*> (CFV s vs) = CFV s (fmap (v1 <*>) vs)
|
||||
(CSusp i k) <*> v2 = CSusp i (\v -> k v <*> v2)
|
||||
v1 <*> (CSusp i k) = CSusp i (\v -> v1 <*> k v)
|
||||
NonExist <*> _ = NonExist
|
||||
@@ -192,7 +192,7 @@ eval g env s (P t lbl) vs = let project (VR as) = case lookup lbl a
|
||||
Nothing -> VError ("Missing value for label" <+> pp lbl $$
|
||||
"in" <+> pp (P t lbl))
|
||||
Just v -> apply g v vs
|
||||
project (VFV s fvs) = VFV s (mapVariants project fvs)
|
||||
project (VFV s fvs) = VFV s (fmap project fvs)
|
||||
project (VMeta i vs) = VSusp i (\v -> project (apply g v vs)) []
|
||||
project (VSusp i k vs) = VSusp i (\v -> project (apply g (k v) vs)) []
|
||||
project v = VP v lbl vs
|
||||
@@ -201,8 +201,8 @@ eval g env s (ExtR t1 t2) [] = let (s1,s2) = split s
|
||||
|
||||
extend (VR as1) (VR as2) = VR (foldl (\as (lbl,v) -> update lbl v as) as1 as2)
|
||||
extend (VRecType as1 e1) (VRecType as2 e2)=VRecType (foldl (\as (lbl,o,v) -> update3 lbl o v as) as1 as2) (e1 || e2)
|
||||
extend (VFV i fvs) v2 = VFV i (mapVariants (`extend` v2) fvs)
|
||||
extend v1 (VFV i fvs) = VFV i (mapVariants (v1 `extend`) fvs)
|
||||
extend (VFV i fvs) v2 = VFV i (fmap (`extend` v2) fvs)
|
||||
extend v1 (VFV i fvs) = VFV i (fmap (v1 `extend`) fvs)
|
||||
extend (VMeta i vs) v2 = VSusp i (\v -> extend (apply g v vs) v2) []
|
||||
extend v1 (VMeta i vs) = VSusp i (\v -> extend v1 (apply g v vs)) []
|
||||
extend (VSusp i k vs) v2 = VSusp i (\v -> extend (apply g (k v) vs) v2) []
|
||||
@@ -230,7 +230,7 @@ eval g env s (S t1 t2) vs = let (!s1,!s2) = split s
|
||||
Success tys ws -> case tys of
|
||||
[ty] -> vtableSelect g v0 ty tvs v2 vs
|
||||
tys -> vtableSelect g v0 (FV (reverse tys)) tvs v2 vs
|
||||
select (VFV i fvs) = VFV i (mapVariants select fvs)
|
||||
select (VFV i fvs) = VFV i (fmap select fvs)
|
||||
select (VMeta i vs) = VSusp i (\v -> select (apply g v vs)) []
|
||||
select (VSusp i k vs) = VSusp i (\v -> select (apply g (k v) vs)) []
|
||||
select v1 = v0
|
||||
@@ -253,8 +253,8 @@ eval g env s (C t1 t2) [] = let (!s1,!s2) = split s
|
||||
|
||||
concat v1 VEmpty = v1
|
||||
concat VEmpty v2 = v2
|
||||
concat (VFV i fvs) v2 = VFV i (mapVariants (`concat` v2) fvs)
|
||||
concat v1 (VFV i fvs) = VFV i (mapVariants (v1 `concat`) fvs)
|
||||
concat (VFV i fvs) v2 = VFV i (fmap (`concat` v2) fvs)
|
||||
concat v1 (VFV i fvs) = VFV i (fmap (v1 `concat`) fvs)
|
||||
concat (VMeta i vs) v2 = VSusp i (\v -> concat (apply g v vs) v2) []
|
||||
concat v1 (VMeta i vs) = VSusp i (\v -> concat v1 (apply g v vs)) []
|
||||
concat (VSusp i k vs) v2 = VSusp i (\v -> concat (apply g (k v) vs) v2) []
|
||||
@@ -276,8 +276,8 @@ eval g env s (Glue t1 t2) [] = let (!s1,!s2) = split s
|
||||
glue v (VAlts d vas) = VAlts (glue v d) [(glue v v',ss) | (v',ss) <- vas]
|
||||
glue (VAlts d vas) (VStr s) = pre d vas s
|
||||
glue (VAlts d vas) v = glue d v
|
||||
glue (VFV i fvs) v2 = VFV i (mapVariants (`glue` v2) fvs)
|
||||
glue v1 (VFV i fvs) = VFV i (mapVariants (v1 `glue`) fvs)
|
||||
glue (VFV i fvs) v2 = VFV i (fmap (`glue` v2) fvs)
|
||||
glue v1 (VFV i fvs) = VFV i (fmap (v1 `glue`) fvs)
|
||||
glue (VMeta i vs) v2 = VSusp i (\v -> glue (apply g v vs) v2) []
|
||||
glue v1 (VMeta i vs) = VSusp i (\v -> glue v1 (apply g v vs)) []
|
||||
glue (VSusp i k vs) v2 = VSusp i (\v -> glue (apply g (k v) vs) v2) []
|
||||
@@ -327,7 +327,7 @@ evalPredef g@(Gl gr pds) c n args =
|
||||
case Map.lookup n pds of
|
||||
Nothing -> VApp c (cPredef,n) args
|
||||
Just def -> let valueOf (Const res) = res
|
||||
valueOf (CFV i vs) = VFV i (mapVariants valueOf vs)
|
||||
valueOf (CFV i vs) = VFV i (fmap valueOf vs)
|
||||
valueOf (CSusp i k) = VSusp i (valueOf . k) []
|
||||
valueOf RunTime = VApp c (cPredef,n) args
|
||||
valueOf NonExist = VApp c (cPredef,cNonExist) []
|
||||
@@ -362,7 +362,7 @@ apply g (VApp c f@(m,n) vs0) vs
|
||||
| m == cPredef = evalPredef g c n (vs0++vs)
|
||||
| otherwise = VApp c f (vs0++vs)
|
||||
apply g (VGen i vs0) vs = VGen i (vs0++vs)
|
||||
apply g (VFV i fvs) vs = VFV i (mapVariants (\v -> apply g v vs) fvs)
|
||||
apply g (VFV i fvs) vs = VFV i (fmap (\v -> apply g v vs) fvs)
|
||||
apply g (VS v1 v2 vs') vs = VS v1 v2 (vs'++vs)
|
||||
apply g (VClosure env s (Abs b x t)) (v:vs) = eval g ((x,v):env) s t vs
|
||||
apply g v [] = v
|
||||
@@ -546,7 +546,7 @@ patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
|
||||
(p, VMeta i vs) -> VSusp i (\v -> match' env p ps eqs (apply g v vs) args) []
|
||||
(p, VGen i vs) -> v0
|
||||
(p, VSusp i k vs) -> VSusp i (\v -> match' env p ps eqs (apply g (k v) vs) args) []
|
||||
(p, VFV s vs) -> VFV s (mapVariants (\arg -> match' env p ps eqs arg args) vs)
|
||||
(p, VFV s vs) -> VFV s (fmap (\arg -> match' env p ps eqs arg args) vs)
|
||||
(PP q qs, VApp c r vs)
|
||||
| q == r -> match env (qs++ps) eqs (vs++args)
|
||||
(PR pas, VR as) -> matchRec env (reverse pas) as ps eqs args
|
||||
@@ -605,7 +605,7 @@ vtableSelect g v0 ty cs v2 vs =
|
||||
where
|
||||
select (Const (i,_)) = cs !! i
|
||||
select (CSusp i k) = VSusp i (\v -> select (k v)) []
|
||||
select (CFV c vs) = VFV c (mapVariants select vs)
|
||||
select (CFV c vs) = VFV c (fmap select vs)
|
||||
select _ = v0
|
||||
|
||||
value2index (VMeta i vs) ty = CSusp i (\v -> value2index (apply g v vs) ty)
|
||||
@@ -645,7 +645,7 @@ vtableSelect g v0 ty cs v2 vs =
|
||||
Gl gr _ = g
|
||||
value2index (VInt n) ty
|
||||
| Just max <- isTypeInts ty = Const (fromIntegral n,fromIntegral max+1)
|
||||
value2index (VFV c vs) ty = CFV c (mapVariants (\v -> value2index v ty) vs)
|
||||
value2index (VFV c vs) ty = CFV c (fmap (\v -> value2index v ty) vs)
|
||||
value2index v ty = RunTime
|
||||
|
||||
|
||||
@@ -1098,7 +1098,7 @@ value2string' g VEmpty b ws qs = Const (b,ws,qs)
|
||||
value2string' g (VC v1 v2) b ws qs = concat v1 (value2string' g v2 b ws qs)
|
||||
where
|
||||
concat v1 (Const (b,ws,qs)) = value2string' g v1 b ws qs
|
||||
concat v1 (CFV c vs) = CFV c (mapVariants (concat v1) vs)
|
||||
concat v1 (CFV c vs) = CFV c (fmap (concat v1) vs)
|
||||
concat v1 res = res
|
||||
value2string' g (VApp c q []) b ws qs
|
||||
| q == (cPredef,cNonExist) = NonExist
|
||||
@@ -1132,7 +1132,7 @@ value2string' g (VAlts vd vas) b ws qs =
|
||||
| or [startsWith s w | VStr s <- ss] = value2string' g v
|
||||
| otherwise = pre vd vas w
|
||||
value2string' g (VFV s vs) b ws qs =
|
||||
CFV s (mapVariants (\v -> value2string' g v b ws qs) vs)
|
||||
CFV s (fmap (\v -> value2string' g v b ws qs) vs)
|
||||
value2string' _ _ _ _ _ = RunTime
|
||||
|
||||
startsWith [] _ = True
|
||||
@@ -1149,13 +1149,13 @@ string2value' (w:ws) = VC (VStr w) (string2value' ws)
|
||||
value2int g (VMeta i vs) = CSusp i (\v -> value2int g (apply g v vs))
|
||||
value2int g (VSusp i k vs) = CSusp i (\v -> value2int g (apply g (k v) vs))
|
||||
value2int g (VInt n) = Const n
|
||||
value2int g (VFV s vs) = CFV s (mapVariants (value2int g) vs)
|
||||
value2int g (VFV s vs) = CFV s (fmap (value2int g) vs)
|
||||
value2int g _ = RunTime
|
||||
|
||||
value2float g (VMeta i vs) = CSusp i (\v -> value2float g (apply g v vs))
|
||||
value2float g (VSusp i k vs) = CSusp i (\v -> value2float g (apply g (k v) vs))
|
||||
value2float g (VFlt f) = Const f
|
||||
value2float g (VFV s vs) = CFV s (mapVariants (value2float g) vs)
|
||||
value2float g (VFV s vs) = CFV s (fmap (value2float g) vs)
|
||||
value2float g _ = RunTime
|
||||
|
||||
value2expr g xs (VApp _ (m,f) vs)
|
||||
@@ -1169,7 +1169,7 @@ value2expr g xs (VClosure env s (Abs b x t)) =
|
||||
in fmap (EAbs b (showIdent x')) (value2expr g (x':xs) v)
|
||||
value2expr g xs (VInt n) = pure (ELit (LInt n))
|
||||
value2expr g xs (VFlt f) = pure (ELit (LFlt f))
|
||||
value2expr g xs (VFV s vs) = CFV s (mapVariants (value2expr g xs) vs)
|
||||
value2expr g xs (VFV s vs) = CFV s (fmap (value2expr g xs) vs)
|
||||
value2expr g xs v = fmap (ELit . LStr) (value2string g v)
|
||||
|
||||
newtype Choice = Choice { unchoice :: Integer }
|
||||
|
||||
@@ -1,183 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : PatternMatch
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/12 12:38:29 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.7 $
|
||||
--
|
||||
-- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.PatternMatch (
|
||||
matchPattern,
|
||||
testOvershadow,
|
||||
findMatch
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Macros
|
||||
--import GF.Grammar.Printer
|
||||
|
||||
import Data.Maybe(fromMaybe)
|
||||
import Control.Monad
|
||||
import GF.Text.Pretty
|
||||
--import Debug.Trace
|
||||
|
||||
matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
|
||||
matchPattern pts term =
|
||||
if not (isInConstantForm term)
|
||||
then raise (render ("variables occur in" <+> pp term))
|
||||
else do
|
||||
term' <- mkK term
|
||||
errIn (render ("trying patterns" <+> hsep (punctuate ',' (map fst pts)))) $
|
||||
findMatch [([p],t) | (p,t) <- pts] [term']
|
||||
where
|
||||
-- to capture all Str with string pattern matching
|
||||
mkK s = case s of
|
||||
C _ _ -> do
|
||||
s' <- getS s
|
||||
return (K (unwords s'))
|
||||
_ -> return s
|
||||
|
||||
getS s = case s of
|
||||
K w -> return [w]
|
||||
C v w -> liftM2 (++) (getS v) (getS w)
|
||||
Empty -> return []
|
||||
_ -> raise (render ("cannot get string from" <+> s))
|
||||
|
||||
testOvershadow :: ErrorMonad m => [Patt] -> [Term] -> m [Patt]
|
||||
testOvershadow pts vs = do
|
||||
let numpts = zip pts [0..]
|
||||
let cases = [(p,EInt i) | (p,i) <- numpts]
|
||||
ts <- mapM (liftM fst . matchPattern cases) vs
|
||||
return [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ]
|
||||
|
||||
findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
|
||||
findMatch cases terms = case cases of
|
||||
[] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms)))
|
||||
(patts,_):_ | length patts /= length terms ->
|
||||
raise (render ("wrong number of args for patterns :" <+> hsep patts <+>
|
||||
"cannot take" <+> hsep terms))
|
||||
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
|
||||
Ok substs -> return (val, concat substs)
|
||||
_ -> findMatch cc terms
|
||||
|
||||
tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
|
||||
tryMatch (p,t) = do
|
||||
t' <- termForm t
|
||||
trym p t'
|
||||
where
|
||||
trym p t' =
|
||||
case (p,t') of
|
||||
-- (_,(x,Typed e ty,y)) -> trym p (x,e,y) -- Add this? /TH 2013-09-05
|
||||
(_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = []
|
||||
(PW, _) -> return [] -- optimization with wildcard
|
||||
(PV x,([],K s,[])) -> return [(x,words2term (words s))]
|
||||
(PV x, _) -> return [(x,t)]
|
||||
(PString s, ([],K i,[])) | s==i -> return []
|
||||
(PInt s, ([],EInt i,[])) | s==i -> return []
|
||||
(PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
|
||||
(PC p pp, ([], Con f, tt)) |
|
||||
p `eqStrIdent` f && length pp == length tt ->
|
||||
do matches <- mapM tryMatch (zip pp tt)
|
||||
return (concat matches)
|
||||
|
||||
(PP (q,p) pp, ([], QC (r,f), tt)) |
|
||||
-- q `eqStrIdent` r && --- not for inherited AR 10/10/2005
|
||||
p `eqStrIdent` f && length pp == length tt ->
|
||||
do matches <- mapM tryMatch (zip pp tt)
|
||||
return (concat matches)
|
||||
---- hack for AppPredef bug
|
||||
(PP (q,p) pp, ([], Q (r,f), tt)) |
|
||||
-- q `eqStrIdent` r && ---
|
||||
p `eqStrIdent` f && length pp == length tt ->
|
||||
do matches <- mapM tryMatch (zip pp tt)
|
||||
return (concat matches)
|
||||
|
||||
(PR r, ([],R r',[])) |
|
||||
all (`elem` map fst r') (map fst r) ->
|
||||
do matches <- mapM tryMatch
|
||||
[(p,snd a) | (l,p) <- r, let Just a = lookup l r']
|
||||
return (concat matches)
|
||||
(PT _ p',_) -> trym p' t'
|
||||
|
||||
(PAs x p',([],K s,[])) -> do
|
||||
subst <- trym p' t'
|
||||
return $ (x,words2term (words s)) : subst
|
||||
|
||||
(PAs x p',_) -> do
|
||||
subst <- trym p' t'
|
||||
return $ (x,t) : subst
|
||||
|
||||
(PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t']
|
||||
|
||||
(PNeg p',_) -> case tryMatch (p',t) of
|
||||
Bad _ -> return []
|
||||
_ -> raise (render ("no match with negative pattern" <+> p))
|
||||
|
||||
(PSeq min1 max1 p1 min2 max2 p2, ([],K s, [])) -> matchPSeq min1 max1 p1 min2 max2 p2 s
|
||||
|
||||
(PRep _ _ p1, ([],K s, [])) -> checks [
|
||||
trym (foldr (const (PSeq 0 Nothing p1 0 Nothing)) (PString "")
|
||||
[1..n]) t' | n <- [0 .. length s]
|
||||
] >>
|
||||
return []
|
||||
|
||||
(PChar, ([],K [_], [])) -> return []
|
||||
(PChars cs, ([],K [c], [])) | elem c cs -> return []
|
||||
|
||||
_ -> raise (render ("no match in case expr for" <+> t))
|
||||
|
||||
words2term [] = Empty
|
||||
words2term [w] = K w
|
||||
words2term (w:ws) = C (K w) (words2term ws)
|
||||
|
||||
matchPSeq min1 max1 p1 min2 max2 p2 s =
|
||||
do let n = length s
|
||||
lo = min1 `max` (n-fromMaybe n max2)
|
||||
hi = (n-min2) `min` (fromMaybe n max1)
|
||||
cuts = [splitAt i s | i <- [lo..hi]]
|
||||
matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
|
||||
return (concat matches)
|
||||
|
||||
isInConstantForm :: Term -> Bool
|
||||
isInConstantForm trm = case trm of
|
||||
Cn _ -> True
|
||||
Con _ -> True
|
||||
Q _ -> True
|
||||
QC _ -> True
|
||||
Abs _ _ _ -> True
|
||||
C c a -> isInConstantForm c && isInConstantForm a
|
||||
App c a -> isInConstantForm c && isInConstantForm a
|
||||
R r -> all (isInConstantForm . snd . snd) r
|
||||
K _ -> True
|
||||
Empty -> True
|
||||
EInt _ -> True
|
||||
V ty ts -> isInConstantForm ty && all isInConstantForm ts -- TH 2013-09-05
|
||||
-- Typed e t-> isInConstantForm e && isInConstantForm t -- Add this? TH 2013-09-05
|
||||
|
||||
_ -> False ---- isInArgVarForm trm
|
||||
{- -- unused and suspicuous, see contP in GF.Compile.Compute.Concrete instead
|
||||
varsOfPatt :: Patt -> [Ident]
|
||||
varsOfPatt p = case p of
|
||||
PV x -> [x]
|
||||
PC _ ps -> concat $ map varsOfPatt ps
|
||||
PP _ ps -> concat $ map varsOfPatt ps
|
||||
PR r -> concat $ map (varsOfPatt . snd) r
|
||||
PT _ q -> varsOfPatt q
|
||||
_ -> []
|
||||
|
||||
-- | to search matching parameter combinations in tables
|
||||
isMatchingForms :: [Patt] -> [Term] -> Bool
|
||||
isMatchingForms ps ts = all match (zip ps ts') where
|
||||
match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds
|
||||
match _ = True
|
||||
ts' = map appForm ts
|
||||
|
||||
-}
|
||||
@@ -146,7 +146,6 @@ library
|
||||
GF.Grammar.Lookup
|
||||
GF.Grammar.Macros
|
||||
GF.Grammar.Parser
|
||||
GF.Grammar.PatternMatch
|
||||
GF.Grammar.Predef
|
||||
GF.Grammar.Printer
|
||||
GF.Grammar.ShowTerm
|
||||
|
||||
Reference in New Issue
Block a user