mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-22 11:19:32 -06:00
use ByteString internally in Ident, CId and Label
This commit is contained in:
kr.angelov
@@ -15,12 +15,13 @@
|
||||
module GF.Grammar.AppPredefined (isInPredefined, typPredefined, appPredefined
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Infra.Ident
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.PrGrammar (prt,prt_,prtBad)
|
||||
---- import PGrammar (pTrm)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
-- predefined function type signatures and definitions. AR 12/3/2003.
|
||||
|
||||
@@ -28,75 +29,77 @@ isInPredefined :: Ident -> Bool
|
||||
isInPredefined = err (const True) (const False) . typPredefined
|
||||
|
||||
typPredefined :: Ident -> Err Type
|
||||
typPredefined c@(IC f) = case f of
|
||||
"Int" -> return typePType
|
||||
"Float" -> return typePType
|
||||
"Error" -> return typeType
|
||||
"Ints" -> return $ mkFunType [cnPredef "Int"] typePType
|
||||
"PBool" -> return typePType
|
||||
"error" -> return $ mkFunType [typeStr] (cnPredef "Error") -- non-can. of empty set
|
||||
"PFalse" -> return $ cnPredef "PBool"
|
||||
"PTrue" -> return $ cnPredef "PBool"
|
||||
"dp" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
|
||||
"drop" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
|
||||
"eqInt" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
|
||||
"lessInt"-> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
|
||||
"eqStr" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
|
||||
"length" -> return $ mkFunType [typeTok] (cnPredef "Int")
|
||||
"occur" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
|
||||
"occurs" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
|
||||
"plus" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "Int")
|
||||
typPredefined f
|
||||
| f == cInt = return typePType
|
||||
| f == cFloat = return typePType
|
||||
| f == cErrorType = return typeType
|
||||
| f == cInts = return $ mkFunType [typeInt] typePType
|
||||
| f == cPBool = return typePType
|
||||
| f == cError = return $ mkFunType [typeStr] typeError -- non-can. of empty set
|
||||
| f == cPFalse = return $ typePBool
|
||||
| f == cPTrue = return $ typePBool
|
||||
| f == cDp = return $ mkFunType [typeInt,typeTok] typeTok
|
||||
| f == cDrop = return $ mkFunType [typeInt,typeTok] typeTok
|
||||
| f == cEqInt = return $ mkFunType [typeInt,typeInt] typePBool
|
||||
| f == cLessInt = return $ mkFunType [typeInt,typeInt] typePBool
|
||||
| f == cEqStr = return $ mkFunType [typeTok,typeTok] typePBool
|
||||
| f == cLength = return $ mkFunType [typeTok] typeInt
|
||||
| f == cOccur = return $ mkFunType [typeTok,typeTok] typePBool
|
||||
| f == cOccurs = return $ mkFunType [typeTok,typeTok] typePBool
|
||||
| f == cPlus = return $ mkFunType [typeInt,typeInt] (typeInt)
|
||||
---- "read" -> (P : Type) -> Tok -> P
|
||||
"show" -> return $ mkProd -- (P : PType) -> P -> Tok
|
||||
([(zIdent "P",typePType),(wildIdent,Vr (zIdent "P"))],typeStr,[])
|
||||
"toStr" -> return $ mkProd -- (L : Type) -> L -> Str
|
||||
([(zIdent "L",typeType),(wildIdent,Vr (zIdent "L"))],typeStr,[])
|
||||
"mapStr" ->
|
||||
let ty = zIdent "L" in
|
||||
return $ mkProd -- (L : Type) -> (Str -> Str) -> L -> L
|
||||
([(ty,typeType),(wildIdent,mkFunType [typeStr] typeStr),(wildIdent,Vr ty)],Vr ty,[])
|
||||
"take" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
|
||||
"tk" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
|
||||
_ -> prtBad "unknown in Predef:" c
|
||||
typPredefined c = prtBad "unknown in Predef:" c
|
||||
| f == cShow = return $ mkProd -- (P : PType) -> P -> Tok
|
||||
([(varP,typePType),(identW,Vr varP)],typeStr,[])
|
||||
| f == cToStr = return $ mkProd -- (L : Type) -> L -> Str
|
||||
([(varL,typeType),(identW,Vr varL)],typeStr,[])
|
||||
| f == cMapStr = return $ mkProd -- (L : Type) -> (Str -> Str) -> L -> L
|
||||
([(varL,typeType),(identW,mkFunType [typeStr] typeStr),(identW,Vr varL)],Vr varL,[])
|
||||
| f == cTake = return $ mkFunType [typeInt,typeTok] typeTok
|
||||
| f == cTk = return $ mkFunType [typeInt,typeTok] typeTok
|
||||
| otherwise = prtBad "unknown in Predef:" f
|
||||
|
||||
varL :: Ident
|
||||
varL = identC (BS.pack "L")
|
||||
|
||||
varP :: Ident
|
||||
varP = identC (BS.pack "P")
|
||||
|
||||
appPredefined :: Term -> Err (Term,Bool)
|
||||
appPredefined t = case t of
|
||||
|
||||
App f x0 -> do
|
||||
(x,_) <- appPredefined x0
|
||||
case f of
|
||||
-- one-place functions
|
||||
Q (IC "Predef") (IC f) -> case (f, x) of
|
||||
("length", K s) -> retb $ EInt $ toInteger $ length s
|
||||
_ -> retb t ---- prtBad "cannot compute predefined" t
|
||||
Q mod f | mod == cPredef ->
|
||||
case x of
|
||||
(K s) | f == cLength -> retb $ EInt $ toInteger $ length s
|
||||
_ -> retb t
|
||||
|
||||
-- two-place functions
|
||||
App (Q (IC "Predef") (IC f)) z0 -> do
|
||||
App (Q mod f) z0 | mod == cPredef -> do
|
||||
(z,_) <- appPredefined z0
|
||||
case (f, norm z, norm x) of
|
||||
("drop", EInt i, K s) -> retb $ K (drop (fi i) s)
|
||||
("take", EInt i, K s) -> retb $ K (take (fi i) s)
|
||||
("tk", EInt i, K s) -> retb $ K (take (max 0 (length s - fi i)) s)
|
||||
("dp", EInt i, K s) -> retb $ K (drop (max 0 (length s - fi i)) s)
|
||||
("eqStr",K s, K t) -> retb $ if s == t then predefTrue else predefFalse
|
||||
("occur",K s, K t) -> retb $ if substring s t then predefTrue else predefFalse
|
||||
("occurs",K s, K t) -> retb $ if any (flip elem t) s then predefTrue else predefFalse
|
||||
("eqInt",EInt i, EInt j) -> retb $ if i==j then predefTrue else predefFalse
|
||||
("lessInt",EInt i, EInt j) -> retb $ if i<j then predefTrue else predefFalse
|
||||
("plus", EInt i, EInt j) -> retb $ EInt $ i+j
|
||||
("show", _, t) -> retb $ foldr C Empty $ map K $ words $ prt t
|
||||
("read", _, K s) -> retb $ str2tag s --- because of K, only works for atomic tags
|
||||
("toStr", _, t) -> trm2str t >>= retb
|
||||
|
||||
case (norm z, norm x) of
|
||||
(EInt i, K s) | f == cDrop -> retb $ K (drop (fi i) s)
|
||||
(EInt i, K s) | f == cTake -> retb $ K (take (fi i) s)
|
||||
(EInt i, K s) | f == cTk -> retb $ K (take (max 0 (length s - fi i)) s)
|
||||
(EInt i, K s) | f == cDp -> retb $ K (drop (max 0 (length s - fi i)) s)
|
||||
(K s, K t) | f == cEqStr -> retb $ if s == t then predefTrue else predefFalse
|
||||
(K s, K t) | f == cOccur -> retb $ if substring s t then predefTrue else predefFalse
|
||||
(K s, K t) | f == cOccurs -> retb $ if any (flip elem t) s then predefTrue else predefFalse
|
||||
(EInt i, EInt j) | f == cEqInt -> retb $ if i==j then predefTrue else predefFalse
|
||||
(EInt i, EInt j) | f == cLessInt -> retb $ if i<j then predefTrue else predefFalse
|
||||
(EInt i, EInt j) | f == cPlus -> retb $ EInt $ i+j
|
||||
(_, t) | f == cShow -> retb $ foldr C Empty $ map K $ words $ prt t
|
||||
(_, K s) | f == cRead -> retb $ Cn (identC (BS.pack s)) --- because of K, only works for atomic tags
|
||||
(_, t) | f == cToStr -> trm2str t >>= retb
|
||||
_ -> retb t ---- prtBad "cannot compute predefined" t
|
||||
|
||||
-- three-place functions
|
||||
App (App (Q (IC "Predef") (IC f)) z0) y0 -> do
|
||||
App (App (Q mod f) z0) y0 | mod == cPredef -> do
|
||||
(y,_) <- appPredefined y0
|
||||
(z,_) <- appPredefined z0
|
||||
case (f, z, y, x) of
|
||||
("mapStr",ty,op,t) -> retf $ mapStr ty op t
|
||||
case (z, y, x) of
|
||||
(ty,op,t) | f == cMapStr -> retf $ mapStr ty op t
|
||||
_ -> retb t ---- prtBad "cannot compute predefined" t
|
||||
|
||||
_ -> retb t ---- prtBad "cannot compute predefined" t
|
||||
@@ -112,19 +115,8 @@ appPredefined t = case t of
|
||||
|
||||
-- read makes variables into constants
|
||||
|
||||
str2tag :: String -> Term
|
||||
str2tag s = case s of
|
||||
---- '\'' : cs -> mkCn $ pTrm $ init cs
|
||||
_ -> Cn $ IC s ---
|
||||
where
|
||||
mkCn t = case t of
|
||||
Vr i -> Cn i
|
||||
App c a -> App (mkCn c) (mkCn a)
|
||||
_ -> t
|
||||
|
||||
|
||||
predefTrue = Q (IC "Predef") (IC "PTrue")
|
||||
predefFalse = Q (IC "Predef") (IC "PFalse")
|
||||
predefTrue = Q cPredef cPTrue
|
||||
predefFalse = Q cPredef cPFalse
|
||||
|
||||
substring :: String -> String -> Bool
|
||||
substring s t = case (s,t) of
|
||||
|
||||
Reference in New Issue
Block a user