mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-22 19:22:50 -06:00
nonExist now does the expected thing
This commit is contained in:
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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]
|
||||
|
||||
|
||||
Reference in New Issue
Block a user