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

nonExist now does the expected thing

Browse Source
This commit is contained in:
kr.angelov
2013-08-23 13:17:45 +00:00
parent 7c98267193
commit a20cd77d25
13 changed files with 70 additions and 15 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/compiler/GF/Compile/Compute/AppPredefined.hs
View File

@@ -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)

6
src/compiler/GF/Compile/Compute/ConcreteNew.hs
View File

@@ -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

37
src/compiler/GF/Compile/Compute/Predef.hs
View File

@@ -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

2
src/compiler/GF/Compile/Compute/Value.hs
View File

@@ -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)

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

@@ -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

4
src/compiler/GF/Grammar/Predef.hs
View File

@@ -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]

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

@@ -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;

4
src/runtime/c/pgf/linearizer.c
View File

@@ -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();
}

7
src/runtime/c/pgf/parser.c
View File

@@ -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:

4
src/runtime/c/pgf/printer.c
View File

@@ -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();
}

7
src/runtime/c/pgf/reader.c
View File

@@ -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);
}

2
src/runtime/haskell/PGF/Binary.hs
View File

@@ -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

1
src/runtime/haskell/PGF/Data.hs
View File

@@ -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]