From 288bcafb79e66eef740589d351964a9411fea14b Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Fri, 23 Aug 2013 13:17:45 +0000 Subject: [PATCH] nonExist now does the expected thing --- lib/src/prelude/Predef.gf | 2 +- lib/src/prelude/Prelude.gf | 2 +- .../GF/Compile/Compute/AppPredefined.hs | 2 + .../GF/Compile/Compute/ConcreteNew.hs | 6 ++- src/compiler/GF/Compile/Compute/Predef.hs | 37 +++++++++++++------ src/compiler/GF/Compile/Compute/Value.hs | 2 +- src/compiler/GF/Compile/GeneratePMCFG.hs | 4 ++ src/compiler/GF/Grammar/Predef.hs | 4 ++ src/runtime/c/pgf/data.h | 5 ++- src/runtime/c/pgf/linearizer.c | 4 ++ src/runtime/c/pgf/parser.c | 7 ++++ src/runtime/c/pgf/printer.c | 4 ++ src/runtime/c/pgf/reader.c | 7 ++++ src/runtime/haskell/PGF/Binary.hs | 2 + src/runtime/haskell/PGF/Data.hs | 1 + 15 files changed, 72 insertions(+), 17 deletions(-) diff --git a/lib/src/prelude/Predef.gf b/lib/src/prelude/Predef.gf index 15eec3984..abe6563ad 100644 --- a/lib/src/prelude/Predef.gf +++ b/lib/src/prelude/Predef.gf @@ -36,6 +36,6 @@ resource Predef = { oper toStr : (L : Type) -> L -> Str = variants {} ; -- find the "first" string oper mapStr : (L : Type) -> (Str -> Str) -> L -> L = variants {} ; -- map all strings in a data structure; experimental --- + oper nonExist : Str = variants {} ; -- a placeholder for non-existant morphological forms } ; - diff --git a/lib/src/prelude/Prelude.gf b/lib/src/prelude/Prelude.gf index 8bb2fbee0..027910e3f 100644 --- a/lib/src/prelude/Prelude.gf +++ b/lib/src/prelude/Prelude.gf @@ -35,7 +35,7 @@ oper -- Missing form. - nonExist : Str = variants {} ; + nonExist : Str = Predef.nonExist; -- Optional string with preference on the string vs. empty. diff --git a/src/compiler/GF/Compile/Compute/AppPredefined.hs b/src/compiler/GF/Compile/Compute/AppPredefined.hs index 375564b32..d4b6dfb41 100644 --- a/src/compiler/GF/Compile/Compute/AppPredefined.hs +++ b/src/compiler/GF/Compile/Compute/AppPredefined.hs @@ -83,6 +83,8 @@ primitives = Map.fromList [(Explicit,varL,typeType),(Explicit,identW,Vr varL)] typeStr []))) Nothing) , (cMapStr , ResOper (Just (noLoc (mkProd -- (L : Type) -> (Str -> Str) -> L -> L [(Explicit,varL,typeType),(Explicit,identW,mkFunType [typeStr] typeStr),(Explicit,identW,Vr varL)] (Vr varL) []))) Nothing) + , (cNonExist , ResOper (Just (noLoc (mkProd -- Str + [] typeStr []))) Nothing) ] where fun from to = oper (mkFunType from to) diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs index d35890930..e2dc1f50f 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs +++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs @@ -10,7 +10,7 @@ import GF.Grammar.Lookup(lookupResDefLoc,allParamValues) import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr) import GF.Grammar.PatternMatch(matchPattern,measurePatt) import GF.Grammar.Lockfield(unlockRecord,lockLabel,isLockLabel,lockRecType) -import GF.Compile.Compute.Value hiding (Predefined(..)) +import GF.Compile.Compute.Value hiding (Error) import GF.Compile.Compute.Predef(predef,predefName,delta) import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok) import GF.Data.Operations(Err,err,errIn,maybeErr,combinations,mapPairsM) @@ -169,6 +169,8 @@ vconcat vv@(v1,v2) = case vv of (VString "",_) -> v2 (_,VString "") -> v1 + (VApp NonExist _,_) -> v1 + (_,VApp NonExist _) -> v2 _ -> VC v1 v2 proj l v | isLockLabel l = return (VRec []) @@ -243,6 +245,8 @@ glue env (v1,v2) = glu v1 v2 (v1,VC va vb) -> VC (glu v1 va) vb (VS (VV ty pvs vs) vb,v2) -> VS (VV ty pvs [glu v v2|v<-vs]) vb (v1,VS (VV ty pvs vs) vb) -> VS (VV ty pvs [glu v1 v|v<-vs]) vb + (v1@(VApp NonExist _),_) -> v1 + (_,v2@(VApp NonExist _)) -> v2 -- (v1,v2) -> ok2 VGlue v1 v2 (v1,v2) -> error . render $ ppL loc (hang (text "unsupported token gluing:") 4 diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs index 588b98959..11c4002b8 100644 --- a/src/compiler/GF/Compile/Compute/Predef.hs +++ b/src/compiler/GF/Compile/Compute/Predef.hs @@ -39,6 +39,13 @@ instance Predef String where instance Predef Value where toValue = id fromValue = return + +instance Predef Predefined where + toValue p = VApp p [] + fromValue v = case v of + VApp p _ -> return p + _ -> fail $ "Expected a predefined constant, got something else" + {- instance (Predef a,Predef b) => Predef (a->b) where toValue f = VAbs Explicit (varX 0) $ Bind $ err bug (toValue . f) . fromValue @@ -70,22 +77,23 @@ predefList = -- cShow, cRead, cMapStr, cEqVal (cError,Error), -- Canonical values: - (cPBool,PBool),(cPFalse,PFalse),(cPTrue,PTrue),(cInt,Int),(cInts,Ints)] + (cPBool,PBool),(cPFalse,PFalse),(cPTrue,PTrue),(cInt,Int), + (cInts,Ints),(cNonExist,NonExist)] --- add more functions!!! delta f vs = case f of - Drop -> ap2 (drop::Int->String->String) - Take -> ap2 (take::Int->String->String) - Tk -> ap2 tk - Dp -> ap2 dp - EqStr -> ap2 ((==)::String->String->Bool) - Occur -> ap2 occur - Occurs -> ap2 occurs - ToUpper -> ap1 (map toUpper) - ToLower -> ap1 (map toLower) - IsUpper -> ap1 (all isUpper) - Length -> ap1 (length::String->Int) + Drop -> fromNonExist vs NonExist (ap2 (drop::Int->String->String)) + Take -> fromNonExist vs NonExist (ap2 (take::Int->String->String)) + Tk -> fromNonExist vs NonExist (ap2 tk) + Dp -> fromNonExist vs NonExist (ap2 dp) + EqStr -> fromNonExist vs PFalse (ap2 ((==)::String->String->Bool)) + Occur -> fromNonExist vs PFalse (ap2 occur) + Occurs -> fromNonExist vs PFalse (ap2 occurs) + ToUpper -> fromNonExist vs NonExist (ap1 (map toUpper)) + ToLower -> fromNonExist vs NonExist (ap1 (map toLower)) + IsUpper -> fromNonExist vs PFalse (ap1 (all isUpper)) + Length -> fromNonExist vs (0::Int) (ap1 (length::String->Int)) Plus -> ap2 ((+)::Int->Int->Int) EqInt -> ap2 ((==)::Int->Int->Bool) LessInt -> ap2 ((<)::Int->Int->Bool) @@ -97,6 +105,7 @@ delta f vs = Ints -> canonical PFalse -> canonical PTrue -> canonical + NonExist-> canonical where canonical = delay delay = return (VApp f vs) -- wrong number of arguments @@ -109,6 +118,10 @@ delta f vs = [v1,v2] -> toValue `fmap` (f `fmap` fromValue v1 `ap` fromValue v2) _ -> delay + fromNonExist vs a b + | null [v | v@(VApp NonExist _) <- vs] = b + | otherwise = return (toValue a) + -- unimpl id = bug $ "unimplemented predefined function: "++showIdent id -- problem id vs = bug $ "unexpected arguments: Predef."++showIdent id++" "++show vs diff --git a/src/compiler/GF/Compile/Compute/Value.hs b/src/compiler/GF/Compile/Compute/Value.hs index e05d29e42..7dbaaa193 100644 --- a/src/compiler/GF/Compile/Compute/Value.hs +++ b/src/compiler/GF/Compile/Compute/Value.hs @@ -51,5 +51,5 @@ data Predefined = Drop | Take | Tk | Dp | EqStr | Occur | Occurs | ToUpper {- | Show | Read | ToStr | MapStr | EqVal -} | Error -- Canonical values below: - | PBool | PFalse | PTrue | Int | Ints + | PBool | PFalse | PTrue | Int | Ints | NonExist deriving (Show,Eq,Ord,Ix,Bounded,Enum) diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 2db007635..d34518cf6 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -391,6 +391,10 @@ convertTerm opts sel ctype (Alts s alts) 4 (ppPatt Unqualified 0 p) +convertTerm opts sel ctype (Q (m,f)) + | m == cPredef && + f == cNonExist = return (CStr [SymNE]) + convertTerm opts sel@(CProj l _) ctype (ExtR t1 t2@(R rs2)) | l `elem` map fst rs2 = convertTerm opts sel ctype t2 | otherwise = convertTerm opts sel ctype t1 diff --git a/src/compiler/GF/Grammar/Predef.hs b/src/compiler/GF/Grammar/Predef.hs index 44cc060ec..71b0cef3d 100644 --- a/src/compiler/GF/Grammar/Predef.hs +++ b/src/compiler/GF/Grammar/Predef.hs @@ -21,6 +21,7 @@ module GF.Grammar.Predef , cString , cVar , cInts + , cNonExist , cPBool , cErrorType , cOverload @@ -94,6 +95,9 @@ cOverload = identC (BS.pack "overload") cUndefinedType :: Ident cUndefinedType = identC (BS.pack "UndefinedType") +cNonExist :: Ident +cNonExist = identC (BS.pack "nonExist") + isPredefCat :: Ident -> Bool isPredefCat c = elem c [cInt,cString,cFloat] diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index b7a13d07d..5e32d8e5e 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -180,7 +180,8 @@ typedef enum { PGF_SYMBOL_LIT, PGF_SYMBOL_VAR, PGF_SYMBOL_KS, - PGF_SYMBOL_KP + PGF_SYMBOL_KP, + PGF_SYMBOL_NE } PgfSymbolTag; typedef struct { @@ -208,6 +209,8 @@ typedef struct PgfSymbolKP * symbol. */ } PgfSymbolKP; +typedef struct { +} PgfSymbolNE; typedef GuSeq PgfSequence; // -> PgfSymbol typedef GuList(PgfSequence) PgfSequences; diff --git a/src/runtime/c/pgf/linearizer.c b/src/runtime/c/pgf/linearizer.c index c5aac7f4f..b110f3a78 100644 --- a/src/runtime/c/pgf/linearizer.c +++ b/src/runtime/c/pgf/linearizer.c @@ -532,6 +532,10 @@ pgf_lzr_linearize(PgfConcr* concr, PgfCncTree ctree, size_t lin_idx, PgfLinFuncs } break; } + case PGF_SYMBOL_NE: { + // Nothing to be done here + break; + } default: gu_impossible(); } diff --git a/src/runtime/c/pgf/parser.c b/src/runtime/c/pgf/parser.c index ea68ba8ca..0cf588aa1 100644 --- a/src/runtime/c/pgf/parser.c +++ b/src/runtime/c/pgf/parser.c @@ -163,6 +163,8 @@ pgf_prev_extern_sym(PgfSymbol sym) return *((PgfSymbol*) (((PgfSymbolLit*) i.data)+1)); case PGF_SYMBOL_VAR: return *((PgfSymbol*) (((PgfSymbolVar*) i.data)+1)); + case PGF_SYMBOL_NE: + return *((PgfSymbol*) (((PgfSymbolNE*) i.data)+1)); default: gu_impossible(); return gu_null_variant; @@ -1410,6 +1412,10 @@ pgf_parsing_symbol(PgfParseState* before, PgfParseState* after, case PGF_SYMBOL_VAR: // XXX TODO proper support break; + case PGF_SYMBOL_NE: { + // Nothing to be done here + break; + } default: gu_impossible(); } @@ -2743,6 +2749,7 @@ pgf_parser_leftcorner_item(PgfLeftcornerFn* clo, PgfItem* item) break; } case PGF_SYMBOL_LIT: + case PGF_SYMBOL_NE: // Nothing to be done here break; case PGF_SYMBOL_VAR: diff --git a/src/runtime/c/pgf/printer.c b/src/runtime/c/pgf/printer.c index 71ccda1f4..b0822e577 100644 --- a/src/runtime/c/pgf/printer.c +++ b/src/runtime/c/pgf/printer.c @@ -258,6 +258,10 @@ pgf_print_symbol(PgfSymbol sym, GuWriter *wtr, GuExn *err) gu_printf(wtr, err, "<%d,$%d>", svar->d, svar->r); break; } + case PGF_SYMBOL_NE: { + gu_puts("nonExist", wtr, err); + break; + } default: gu_impossible(); } diff --git a/src/runtime/c/pgf/reader.c b/src/runtime/c/pgf/reader.c index a43ebdba0..f58809ef5 100644 --- a/src/runtime/c/pgf/reader.c +++ b/src/runtime/c/pgf/reader.c @@ -717,6 +717,13 @@ pgf_read_symbol(PgfReader* rdr) } break; } + case PGF_SYMBOL_NE: { + gu_new_variant(PGF_SYMBOL_NE, + PgfSymbolNE, + &sym, rdr->opool); + gu_return_on_exn(rdr->err, gu_null_variant); + break; + } default: pgf_read_tag_error(rdr); } diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs index 0d743c1f4..865f98417 100644 --- a/src/runtime/haskell/PGF/Binary.hs +++ b/src/runtime/haskell/PGF/Binary.hs @@ -152,6 +152,7 @@ instance Binary Symbol where put (SymVar n l) = putWord8 2 >> put (n,l) put (SymKS ts) = putWord8 3 >> put ts put (SymKP d vs) = putWord8 4 >> put (d,vs) + put SymNE = putWord8 5 get = do tag <- getWord8 case tag of 0 -> liftM2 SymCat get get @@ -159,6 +160,7 @@ instance Binary Symbol where 2 -> liftM2 SymVar get get 3 -> liftM SymKS get 4 -> liftM2 (\d vs -> SymKP d vs) get get + 5 -> return SymNE _ -> decodingError instance Binary PArg where diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs index 357dcc92e..58ced6a1e 100644 --- a/src/runtime/haskell/PGF/Data.hs +++ b/src/runtime/haskell/PGF/Data.hs @@ -60,6 +60,7 @@ data Symbol | SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int | SymKS [Token] | SymKP [Token] [Alternative] + | SymNE -- non exist deriving (Eq,Ord,Show) data Production = PApply {-# UNPACK #-} !FunId [PArg]