mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-23 03:32:51 -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
|
||||
|
||||
@@ -48,7 +48,8 @@ module GF.Grammar.Grammar (SourceGrammar,
|
||||
Con,
|
||||
Trm,
|
||||
wildPatt,
|
||||
varLabel
|
||||
varLabel, tupleLabel, linLabel, theLinLabel,
|
||||
ident2label, label2ident
|
||||
) where
|
||||
|
||||
import GF.Data.Str
|
||||
@@ -58,6 +59,8 @@ import GF.Infra.Modules
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
-- | grammar as presented to the compiler
|
||||
type SourceGrammar = MGrammar Ident Option Info
|
||||
|
||||
@@ -119,7 +122,7 @@ data Term =
|
||||
| Cn Ident -- ^ constant
|
||||
| Con Ident -- ^ constructor
|
||||
| EData -- ^ to mark in definition that a fun is a constructor
|
||||
| Sort String -- ^ basic type
|
||||
| Sort Ident -- ^ basic type
|
||||
| EInt Integer -- ^ integer literal
|
||||
| EFloat Double -- ^ floating point literal
|
||||
| K String -- ^ string literal or token: @\"foo\"@
|
||||
@@ -210,7 +213,7 @@ data TInfo =
|
||||
|
||||
-- | record label
|
||||
data Label =
|
||||
LIdent String
|
||||
LIdent BS.ByteString
|
||||
| LVar Int
|
||||
deriving (Read, Show, Eq, Ord)
|
||||
|
||||
@@ -238,7 +241,21 @@ type Con = Ident ---
|
||||
varLabel :: Int -> Label
|
||||
varLabel = LVar
|
||||
|
||||
tupleLabel, linLabel :: Int -> Label
|
||||
tupleLabel i = LIdent $! BS.pack ('p':show i)
|
||||
linLabel i = LIdent $! BS.pack ('s':show i)
|
||||
|
||||
theLinLabel :: Label
|
||||
theLinLabel = LIdent (BS.singleton 's')
|
||||
|
||||
ident2label :: Ident -> Label
|
||||
ident2label c = LIdent (ident2bs c)
|
||||
|
||||
label2ident :: Label -> Ident
|
||||
label2ident (LIdent s) = identC s
|
||||
label2ident (LVar i) = identC (BS.pack ('$':show i))
|
||||
|
||||
wildPatt :: Patt
|
||||
wildPatt = PV wildIdent
|
||||
wildPatt = PV identW
|
||||
|
||||
type Trm = Term
|
||||
|
||||
@@ -16,8 +16,10 @@
|
||||
|
||||
module GF.Grammar.Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where
|
||||
|
||||
import GF.Grammar.Grammar
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.PrGrammar
|
||||
|
||||
@@ -38,9 +40,12 @@ unlockRecord c ft = do
|
||||
return $ mkAbs xs t'
|
||||
|
||||
lockLabel :: Ident -> Label
|
||||
lockLabel c = LIdent $ "lock_" ++ prt c ----
|
||||
lockLabel c = LIdent $! BS.append lockPrefix (ident2bs c)
|
||||
|
||||
isLockLabel :: Label -> Bool
|
||||
isLockLabel l = case l of
|
||||
LIdent c -> take 5 c == "lock_"
|
||||
_ -> False
|
||||
LIdent c -> BS.isPrefixOf lockPrefix c
|
||||
_ -> False
|
||||
|
||||
|
||||
lockPrefix = BS.pack "lock_"
|
||||
|
||||
@@ -115,7 +115,7 @@ lookupRef gr binds at = case at of
|
||||
refsForType :: (Val -> Type -> Bool) -> GFCGrammar -> Binds -> Val -> [(Term,(Val,Bool))]
|
||||
refsForType compat gr binds val =
|
||||
-- bound variables --- never recursive?
|
||||
[(vr i, (t,False)) | (i,t) <- binds, Ok ty <- [val2exp t], compat val ty] ++
|
||||
[(Vr i, (t,False)) | (i,t) <- binds, Ok ty <- [val2exp t], compat val ty] ++
|
||||
-- integer and string literals
|
||||
[(EInt i, (val,False)) | val == valAbsInt, i <- [0,1,2,5,11,1978]] ++
|
||||
[(EFloat i, (val,False)) | val == valAbsFloat, i <- [3.1415926]] ++
|
||||
|
||||
@@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Lookup
|
||||
@@ -28,13 +29,13 @@ module GF.Grammar.Lookup (
|
||||
allParamValues,
|
||||
lookupAbsDef,
|
||||
lookupLincat,
|
||||
opersForType,
|
||||
linTypeInt
|
||||
opersForType
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Abstract
|
||||
import GF.Infra.Modules
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.Lockfield
|
||||
|
||||
import Data.List (nub,sortBy)
|
||||
@@ -192,8 +193,7 @@ allOrigInfos gr m = errVal [] $ do
|
||||
|
||||
allParamValues :: SourceGrammar -> Type -> Err [Term]
|
||||
allParamValues cnc ptyp = case ptyp of
|
||||
App (Q (IC "Predef") (IC "Ints")) (EInt n) ->
|
||||
return [EInt i | i <- [0..n]]
|
||||
_ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
|
||||
QC p c -> lookupParamValues cnc p c
|
||||
Q p c -> lookupParamValues cnc p c ----
|
||||
RecType r -> do
|
||||
@@ -230,17 +230,8 @@ lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do
|
||||
_ -> return Nothing
|
||||
_ -> Bad $ prt m +++ "is not an abstract module"
|
||||
|
||||
linTypeInt :: Type
|
||||
linTypeInt = defLinType
|
||||
--- let ints k = App (Q (IC "Predef") (IC "Ints")) (EInt k) in
|
||||
--- RecType [
|
||||
--- (LIdent "last",ints 9),(LIdent "s", typeStr), (LIdent "size",ints 1)]
|
||||
|
||||
lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type
|
||||
lookupLincat gr m c | elem c [zIdent "Int"] = return linTypeInt
|
||||
lookupLincat gr m c | elem c [zIdent "String", zIdent "Float"] =
|
||||
return defLinType --- ad hoc; not needed?
|
||||
|
||||
lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
|
||||
lookupLincat gr m c = do
|
||||
mi <- lookupModule gr m
|
||||
case mi of
|
||||
@@ -265,7 +256,7 @@ opersForType gr orig val =
|
||||
Ok valt <- [valTypeCnc ty],
|
||||
elem valt [val,orig]
|
||||
] ++
|
||||
let cat = err zIdent snd (valCat orig) in --- ignore module
|
||||
let cat = err error snd (valCat orig) in --- ignore module
|
||||
[(f,ty) |
|
||||
Ok a <- [abstractOfConcrete gr i >>= lookupModMod gr],
|
||||
(f, AbsFun (Yes ty0) _) <- tree2list $ jments a,
|
||||
|
||||
@@ -26,6 +26,7 @@ import GF.Grammar.Values
|
||||
import GF.Grammar.Macros
|
||||
|
||||
import Control.Monad
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
nodeTree :: Tree -> TrNode
|
||||
argsTree :: Tree -> [Tree]
|
||||
@@ -120,9 +121,6 @@ funAtom a = case a of
|
||||
AtC f -> return f
|
||||
_ -> prtBad "not function head" a
|
||||
|
||||
uBoundVar :: Ident
|
||||
uBoundVar = zIdent "#h" -- used for suppressed bindings
|
||||
|
||||
atomIsMeta :: Atom -> Bool
|
||||
atomIsMeta atom = case atom of
|
||||
AtM _ -> True
|
||||
@@ -186,7 +184,7 @@ val2expP safe v = case v of
|
||||
VCn c -> return $ qq c
|
||||
VGen i x -> if safe
|
||||
then prtBad "unsafe val2exp" v
|
||||
else return $ vr $ x --- in editing, no alpha conversions presentv
|
||||
else return $ Vr $ x --- in editing, no alpha conversions presentv
|
||||
where
|
||||
substVal g e = mapPairsM (val2expP safe) g >>= return . (\s -> substTerm [] s e)
|
||||
|
||||
@@ -278,7 +276,7 @@ mkJustProd :: Context -> Term -> Term
|
||||
mkJustProd cont typ = mkProd (cont,typ,[])
|
||||
|
||||
int2var :: Int -> Ident
|
||||
int2var = zIdent . ('$':) . show
|
||||
int2var = identC . BS.pack . ('$':) . show
|
||||
|
||||
meta0 :: Meta
|
||||
meta0 = int2meta 0
|
||||
@@ -301,12 +299,12 @@ qualifTerm m = qualif [] where
|
||||
Cn c -> Q m c
|
||||
Con c -> QC m c
|
||||
_ -> composSafeOp (qualif xs) t
|
||||
chV x = string2var $ prIdent x
|
||||
chV x = string2var $ ident2bs x
|
||||
|
||||
string2var :: String -> Ident
|
||||
string2var s = case s of
|
||||
c:'_':i -> identV (readIntArg i,[c]) ---
|
||||
_ -> zIdent s
|
||||
string2var :: BS.ByteString -> Ident
|
||||
string2var s = case BS.unpack s of
|
||||
c:'_':i -> identV (BS.singleton c) (readIntArg i) ---
|
||||
_ -> identC s
|
||||
|
||||
-- | reindex variables so that they tell nesting depth level
|
||||
reindexTerm :: Term -> Term
|
||||
@@ -317,7 +315,7 @@ reindexTerm = qualif (0,[]) where
|
||||
Vr x -> Vr $ look x g
|
||||
_ -> composSafeOp (qualif dg) t
|
||||
look x = maybe x id . lookup x --- if x is not in scope it is unchanged
|
||||
ind x d = identC $ prIdent x ++ "_" ++ show d
|
||||
ind x d = identC $ ident2bs x `BS.append` BS.singleton '_' `BS.append` BS.pack (show d)
|
||||
|
||||
|
||||
-- this method works for context-free abstract syntax
|
||||
|
||||
@@ -20,8 +20,10 @@ module GF.Grammar.Macros where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Data.Str
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Values
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.PrGrammar
|
||||
|
||||
import Control.Monad (liftM, liftM2)
|
||||
@@ -55,12 +57,6 @@ qq (m,c) = Q m c
|
||||
typeForm :: Type -> Err (Context, Cat, [Term])
|
||||
typeForm = qTypeForm ---- no need to distinguish any more
|
||||
|
||||
cPredef :: Ident
|
||||
cPredef = identC "Predef"
|
||||
|
||||
cnPredef :: String -> Term
|
||||
cnPredef f = Q cPredef (identC f)
|
||||
|
||||
typeFormCnc :: Type -> Err (Context, Type)
|
||||
typeFormCnc t = case t of
|
||||
Prod x a b -> do
|
||||
@@ -91,18 +87,11 @@ typeRawSkeleton typ =
|
||||
|
||||
type MCat = (Ident,Ident)
|
||||
|
||||
sortMCat :: String -> MCat
|
||||
sortMCat s = (zIdent "_", zIdent s)
|
||||
|
||||
--- hack for Editing.actCat in empty state
|
||||
errorCat :: MCat
|
||||
errorCat = (zIdent "?", zIdent "?")
|
||||
|
||||
getMCat :: Term -> Err MCat
|
||||
getMCat t = case t of
|
||||
Q m c -> return (m,c)
|
||||
QC m c -> return (m,c)
|
||||
Sort s -> return $ sortMCat s
|
||||
Sort c -> return (identW, c)
|
||||
App f _ -> getMCat f
|
||||
_ -> prtBad "no qualified constant" t
|
||||
|
||||
@@ -213,12 +202,6 @@ mkAbs xx t = foldr Abs t xx
|
||||
appCons :: Ident -> [Term] -> Term
|
||||
appCons = mkApp . Cn
|
||||
|
||||
appc :: String -> [Term] -> Term
|
||||
appc = appCons . zIdent
|
||||
|
||||
appqc :: String -> String -> [Term] -> Term
|
||||
appqc q c = mkApp (Q (zIdent q) (zIdent c))
|
||||
|
||||
mkLet :: [LocalDef] -> Term -> Term
|
||||
mkLet defs t = foldr Let t defs
|
||||
|
||||
@@ -232,11 +215,8 @@ isVariable _ = False
|
||||
eqIdent :: Ident -> Ident -> Bool
|
||||
eqIdent = (==)
|
||||
|
||||
zIdent :: String -> Ident
|
||||
zIdent s = identC s
|
||||
|
||||
uType :: Type
|
||||
uType = Cn (zIdent "UndefinedType")
|
||||
uType = Cn cUndefinedType
|
||||
|
||||
assign :: Label -> Term -> Assign
|
||||
assign l t = (l,(Nothing,t))
|
||||
@@ -253,15 +233,6 @@ mkAssign lts = [assign l t | (l,t) <- lts]
|
||||
zipAssign :: [Label] -> [Term] -> [Assign]
|
||||
zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
|
||||
|
||||
ident2label :: Ident -> Label
|
||||
ident2label c = LIdent (prIdent c)
|
||||
|
||||
label2ident :: Label -> Ident
|
||||
label2ident = identC . prLabel
|
||||
|
||||
prLabel :: Label -> String
|
||||
prLabel = prt
|
||||
|
||||
mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
|
||||
mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv))
|
||||
where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v)
|
||||
@@ -280,41 +251,40 @@ mkRecType = mkRecTypeN 0
|
||||
|
||||
record2subst :: Term -> Err Substitution
|
||||
record2subst t = case t of
|
||||
R fs -> return [(zIdent x, t) | (LIdent x,(_,t)) <- fs]
|
||||
R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs]
|
||||
_ -> prtBad "record expected, found" t
|
||||
|
||||
typeType, typePType, typeStr, typeTok, typeStrs :: Term
|
||||
|
||||
typeType = srt "Type"
|
||||
typePType = srt "PType"
|
||||
typeStr = srt "Str"
|
||||
typeTok = srt "Tok"
|
||||
typeStrs = srt "Strs"
|
||||
typeType = Sort cType
|
||||
typePType = Sort cPType
|
||||
typeStr = Sort cStr
|
||||
typeTok = Sort cTok
|
||||
typeStrs = Sort cStrs
|
||||
|
||||
typeString, typeFloat, typeInt :: Term
|
||||
typeInts :: Integer -> Term
|
||||
typePBool :: Term
|
||||
typeError :: Term
|
||||
|
||||
typeString = constPredefRes "String"
|
||||
typeInt = constPredefRes "Int"
|
||||
typeFloat = constPredefRes "Float"
|
||||
typeInts i = App (constPredefRes "Ints") (EInt i)
|
||||
typeString = cnPredef cString
|
||||
typeInt = cnPredef cInt
|
||||
typeFloat = cnPredef cFloat
|
||||
typeInts i = App (cnPredef cInts) (EInt i)
|
||||
typePBool = cnPredef cPBool
|
||||
typeError = cnPredef cErrorType
|
||||
|
||||
isTypeInts :: Term -> Bool
|
||||
isTypeInts ty = case ty of
|
||||
App c _ -> c == constPredefRes "Ints"
|
||||
_ -> False
|
||||
|
||||
constPredefRes :: String -> Term
|
||||
constPredefRes s = Q (IC "Predef") (zIdent s)
|
||||
isTypeInts :: Term -> Maybe Integer
|
||||
isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
|
||||
isTypeInts _ = Nothing
|
||||
|
||||
isPredefConstant :: Term -> Bool
|
||||
isPredefConstant t = case t of
|
||||
Q (IC "Predef") _ -> True
|
||||
Q (IC "PredefAbs") _ -> True
|
||||
_ -> False
|
||||
Q mod _ | mod == cPredef || mod == cPredefAbs -> True
|
||||
_ -> False
|
||||
|
||||
isPredefAbsType :: Ident -> Bool
|
||||
isPredefAbsType c = elem c [zIdent "Int", zIdent "String"]
|
||||
cnPredef :: Ident -> Term
|
||||
cnPredef f = Q cPredef f
|
||||
|
||||
mkSelects :: Term -> [Term] -> Term
|
||||
mkSelects t tt = foldl S t tt
|
||||
@@ -327,18 +297,11 @@ mkCTable ids v = foldr ccase v ids where
|
||||
ccase x t = T TRaw [(PV x,t)]
|
||||
|
||||
mkDecl :: Term -> Decl
|
||||
mkDecl typ = (wildIdent, typ)
|
||||
mkDecl typ = (identW, typ)
|
||||
|
||||
eqStrIdent :: Ident -> Ident -> Bool
|
||||
eqStrIdent = (==)
|
||||
|
||||
tupleLabel, linLabel :: Int -> Label
|
||||
tupleLabel i = LIdent $ "p" ++ show i
|
||||
linLabel i = LIdent $ "s" ++ show i
|
||||
|
||||
theLinLabel :: Label
|
||||
theLinLabel = LIdent "s"
|
||||
|
||||
tuple2record :: [Term] -> [Assign]
|
||||
tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]
|
||||
|
||||
@@ -352,10 +315,10 @@ mkCases :: Ident -> Term -> Term
|
||||
mkCases x t = T TRaw [(PV x, t)]
|
||||
|
||||
mkWildCases :: Term -> Term
|
||||
mkWildCases = mkCases wildIdent
|
||||
mkWildCases = mkCases identW
|
||||
|
||||
mkFunType :: [Type] -> Type -> Type
|
||||
mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt], t, []) -- nondep prod
|
||||
mkFunType tt t = mkProd ([(identW, ty) | ty <- tt], t, []) -- nondep prod
|
||||
|
||||
plusRecType :: Type -> Type -> Err Type
|
||||
plusRecType t1 t2 = case (unComputed t1, unComputed t2) of
|
||||
@@ -376,11 +339,7 @@ plusRecord t1 t2 =
|
||||
|
||||
-- | default linearization type
|
||||
defLinType :: Type
|
||||
defLinType = RecType [(LIdent "s", typeStr)]
|
||||
|
||||
-- | refreshing variables
|
||||
varX :: Int -> Ident
|
||||
varX i = identV (i,"x")
|
||||
defLinType = RecType [(theLinLabel, typeStr)]
|
||||
|
||||
-- | refreshing variables
|
||||
mkFreshVar :: [Ident] -> Ident
|
||||
@@ -414,28 +373,12 @@ float2term = EFloat
|
||||
ident2terminal :: Ident -> Term
|
||||
ident2terminal = K . prIdent
|
||||
|
||||
-- | create a constant
|
||||
string2CnTrm :: String -> Term
|
||||
string2CnTrm = Cn . zIdent
|
||||
|
||||
symbolOfIdent :: Ident -> String
|
||||
symbolOfIdent = prIdent
|
||||
|
||||
symid :: Ident -> String
|
||||
symid = symbolOfIdent
|
||||
|
||||
vr :: Ident -> Term
|
||||
cn :: Ident -> Term
|
||||
srt :: String -> Term
|
||||
meta :: MetaSymb -> Term
|
||||
cnIC :: String -> Term
|
||||
|
||||
vr = Vr
|
||||
cn = Cn
|
||||
srt = Sort
|
||||
meta = Meta
|
||||
cnIC = cn . IC
|
||||
|
||||
justIdentOf :: Term -> Maybe Ident
|
||||
justIdentOf (Vr x) = Just x
|
||||
justIdentOf (Cn x) = Just x
|
||||
@@ -490,9 +433,6 @@ linTypeStr = mkRecType linLabel [typeStr] -- default lintype {s :: Str}
|
||||
linAsStr :: String -> Term
|
||||
linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s}
|
||||
|
||||
linDefStr :: Term
|
||||
linDefStr = Abs s (R [assign (linLabel 0) (Vr s)]) where s = zIdent "s"
|
||||
|
||||
term2patt :: Term -> Err Patt
|
||||
term2patt trm = case termForm trm of
|
||||
Ok ([], Vr x, []) -> return (PV x)
|
||||
@@ -516,24 +456,24 @@ term2patt trm = case termForm trm of
|
||||
Ok ([],K s, []) -> return $ PString s
|
||||
|
||||
--- encodings due to excessive use of term-patt convs. AR 7/1/2005
|
||||
Ok ([], Cn (IC "@"), [Vr a,b]) -> do
|
||||
Ok ([], Cn id, [Vr a,b]) | id == cAs -> do
|
||||
b' <- term2patt b
|
||||
return (PAs a b')
|
||||
Ok ([], Cn (IC "-"), [a]) -> do
|
||||
Ok ([], Cn id, [a]) | id == cNeg -> do
|
||||
a' <- term2patt a
|
||||
return (PNeg a')
|
||||
Ok ([], Cn (IC "*"), [a]) -> do
|
||||
Ok ([], Cn id, [a]) | id == cRep -> do
|
||||
a' <- term2patt a
|
||||
return (PRep a')
|
||||
Ok ([], Cn (IC "?"), []) -> do
|
||||
Ok ([], Cn id, []) | id == cRep -> do
|
||||
return PChar
|
||||
Ok ([], Cn (IC "[]"),[K s]) -> do
|
||||
Ok ([], Cn id,[K s]) | id == cChars -> do
|
||||
return $ PChars s
|
||||
Ok ([], Cn (IC "+"), [a,b]) -> do
|
||||
Ok ([], Cn id, [a,b]) | id == cSeq -> do
|
||||
a' <- term2patt a
|
||||
b' <- term2patt b
|
||||
return (PSeq a' b')
|
||||
Ok ([], Cn (IC "|"), [a,b]) -> do
|
||||
Ok ([], Cn id, [a,b]) | id == cAlt -> do
|
||||
a' <- term2patt a
|
||||
b' <- term2patt b
|
||||
return (PAlt a' b')
|
||||
@@ -546,7 +486,7 @@ term2patt trm = case termForm trm of
|
||||
patt2term :: Patt -> Term
|
||||
patt2term pt = case pt of
|
||||
PV x -> Vr x
|
||||
PW -> Vr wildIdent --- not parsable, should not occur
|
||||
PW -> Vr identW --- not parsable, should not occur
|
||||
PVal t i -> Val t i
|
||||
PMacro c -> Cn c
|
||||
PM p c -> Q p c
|
||||
@@ -560,13 +500,13 @@ patt2term pt = case pt of
|
||||
PFloat i -> EFloat i
|
||||
PString s -> K s
|
||||
|
||||
PAs x p -> appc "@" [Vr x, patt2term p] --- an encoding
|
||||
PChar -> appc "?" [] --- an encoding
|
||||
PChars s -> appc "[]" [K s] --- an encoding
|
||||
PSeq a b -> appc "+" [(patt2term a), (patt2term b)] --- an encoding
|
||||
PAlt a b -> appc "|" [(patt2term a), (patt2term b)] --- an encoding
|
||||
PRep a -> appc "*" [(patt2term a)] --- an encoding
|
||||
PNeg a -> appc "-" [(patt2term a)] --- an encoding
|
||||
PAs x p -> appCons cAs [Vr x, patt2term p] --- an encoding
|
||||
PChar -> appCons cChar [] --- an encoding
|
||||
PChars s -> appCons cChars [K s] --- an encoding
|
||||
PSeq a b -> appCons cSeq [(patt2term a), (patt2term b)] --- an encoding
|
||||
PAlt a b -> appCons cAlt [(patt2term a), (patt2term b)] --- an encoding
|
||||
PRep a -> appCons cRep [(patt2term a)] --- an encoding
|
||||
PNeg a -> appCons cNeg [(patt2term a)] --- an encoding
|
||||
|
||||
|
||||
redirectTerm :: Ident -> Term -> Term
|
||||
@@ -575,45 +515,12 @@ redirectTerm n t = case t of
|
||||
Q _ f -> Q n f
|
||||
_ -> composSafeOp (redirectTerm n) t
|
||||
|
||||
-- | to gather s-fields; assumes term in normal form, preserves label
|
||||
allLinFields :: Term -> Err [[(Label,Term)]]
|
||||
allLinFields trm = case unComputed trm of
|
||||
---- R rs -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good
|
||||
R rs -> return [[(l,t) | (l,(_,t)) <- rs, isLinLabel l]] ---- bad
|
||||
FV ts -> do
|
||||
lts <- mapM allLinFields ts
|
||||
return $ concat lts
|
||||
_ -> prtBad "fields can only be sought in a record not in" trm
|
||||
|
||||
-- | deprecated
|
||||
isLinLabel :: Label -> Bool
|
||||
isLinLabel l = case l of
|
||||
LIdent ('s':cs) | all isDigit cs -> True
|
||||
_ -> False
|
||||
|
||||
-- | to gather ultimate cases in a table; preserves pattern list
|
||||
allCaseValues :: Term -> [([Patt],Term)]
|
||||
allCaseValues trm = case unComputed trm of
|
||||
T _ cs -> [(p:ps, t) | (p,t0) <- cs, (ps,t) <- allCaseValues t0]
|
||||
_ -> [([],trm)]
|
||||
|
||||
-- | to gather all linearizations; assumes normal form, preserves label and args
|
||||
allLinValues :: Term -> Err [[(Label,[([Patt],Term)])]]
|
||||
allLinValues trm = do
|
||||
lts <- allLinFields trm
|
||||
mapM (mapPairsM (return . allCaseValues)) lts
|
||||
|
||||
-- | to mark str parts of fields in a record f by a function f
|
||||
markLinFields :: (Term -> Term) -> Term -> Term
|
||||
markLinFields f t = case t of
|
||||
R r -> R $ map mkField r
|
||||
_ -> t
|
||||
where
|
||||
mkField (l,(_,t)) = if (isLinLabel l) then (assign l (mkTbl t)) else (assign l t)
|
||||
mkTbl t = case t of
|
||||
T i cs -> T i [(p, mkTbl v) | (p,v) <- cs]
|
||||
_ -> f t
|
||||
|
||||
-- | to get a string from a term that represents a sequence of terminals
|
||||
strsFromTerm :: Term -> Err [Str]
|
||||
strsFromTerm t = case unComputed t of
|
||||
|
||||
@@ -19,15 +19,15 @@ module GF.Grammar.Values (-- * values used in TC type checking
|
||||
-- * for TC
|
||||
valAbsInt, valAbsFloat, valAbsString, vType,
|
||||
isPredefCat,
|
||||
cType, cPredefAbs, cInt, cFloat, cString,
|
||||
eType, tree2exp, loc2treeFocus
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Data.Zipper
|
||||
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Predef
|
||||
|
||||
-- values used in TC type checking
|
||||
|
||||
@@ -67,26 +67,8 @@ valAbsString = VCn (cPredefAbs, cString)
|
||||
vType :: Val
|
||||
vType = VType
|
||||
|
||||
cType :: Ident
|
||||
cType = identC "Type" --- #0
|
||||
|
||||
cPredefAbs :: Ident
|
||||
cPredefAbs = identC "PredefAbs"
|
||||
|
||||
cInt :: Ident
|
||||
cInt = identC "Int"
|
||||
|
||||
cFloat :: Ident
|
||||
cFloat = identC "Float"
|
||||
|
||||
cString :: Ident
|
||||
cString = identC "String"
|
||||
|
||||
isPredefCat :: Ident -> Bool
|
||||
isPredefCat c = elem c [cInt,cString,cFloat]
|
||||
|
||||
eType :: Exp
|
||||
eType = Sort "Type"
|
||||
eType = Sort cType
|
||||
|
||||
tree2exp :: Tree -> Exp
|
||||
tree2exp (Tr (N (bi,at,_,_,_),ts)) = foldr Abs (foldl App at' ts') bi' where
|
||||
|
||||
Reference in New Issue
Block a user