mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
the abstract syntax for Predef.gf is now hard-coded in AppPredefined.hs
This commit is contained in:
krasimir
@@ -12,58 +12,79 @@
|
||||
-- Predefined function type signatures and definitions.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.Compute.AppPredefined (isInPredefined, typPredefined, appPredefined
|
||||
) where
|
||||
module GF.Compile.Compute.AppPredefined (
|
||||
isInPredefined, typPredefined, arrityPredefined, predefModInfo, appPredefined
|
||||
) where
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Modules
|
||||
import GF.Infra.Option
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.Printer
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Text.PrettyPrint
|
||||
|
||||
-- predefined function type signatures and definitions. AR 12/3/2003.
|
||||
|
||||
isInPredefined :: Ident -> Bool
|
||||
isInPredefined = err (const True) (const False) . typPredefined
|
||||
isInPredefined f = Map.member f primitives
|
||||
|
||||
typPredefined :: Ident -> Err Type
|
||||
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
|
||||
| f == cShow = return $ mkProd -- (P : PType) -> P -> Tok
|
||||
[(Explicit,varP,typePType),(Explicit,identW,Vr varP)] typeStr []
|
||||
| f == cToStr = return $ mkProd -- (L : Type) -> L -> Str
|
||||
[(Explicit,varL,typeType),(Explicit,identW,Vr varL)] typeStr []
|
||||
| f == cMapStr = return $ mkProd -- (L : Type) -> (Str -> Str) -> L -> L
|
||||
[(Explicit,varL,typeType),(Explicit,identW,mkFunType [typeStr] typeStr),(Explicit,identW,Vr varL)] (Vr varL) []
|
||||
| f == cTake = return $ mkFunType [typeInt,typeTok] typeTok
|
||||
| f == cTk = return $ mkFunType [typeInt,typeTok] typeTok
|
||||
| otherwise = Bad (render (text "unknown in Predef:" <+> ppIdent f))
|
||||
typPredefined :: Ident -> Maybe Type
|
||||
typPredefined f = case Map.lookup f primitives of
|
||||
Just (ResOper (Just (L _ ty)) _) -> Just ty
|
||||
Just (ResParam _ _) -> Just typePType
|
||||
Just (ResValue (L _ ty)) -> Just ty
|
||||
_ -> Nothing
|
||||
|
||||
varL :: Ident
|
||||
varL = identC (BS.pack "L")
|
||||
arrityPredefined :: Ident -> Maybe Int
|
||||
arrityPredefined f = do ty <- typPredefined f
|
||||
let (ctxt,_) = typeFormCnc ty
|
||||
return (length ctxt)
|
||||
|
||||
varP :: Ident
|
||||
varP = identC (BS.pack "P")
|
||||
predefModInfo :: SourceModInfo
|
||||
predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] primitives
|
||||
|
||||
primitives = Map.fromList
|
||||
[ (cErrorType, ResOper (Just (noLoc typeType)) Nothing)
|
||||
, (cInt , ResOper (Just (noLoc typePType)) Nothing)
|
||||
, (cFloat , ResOper (Just (noLoc typePType)) Nothing)
|
||||
, (cInts , ResOper (Just (noLoc (mkFunType [typeInt] typePType))) Nothing)
|
||||
, (cPBool , ResParam (Just [noLoc (cPTrue,[]),noLoc (cPFalse,[])]) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
|
||||
, (cPTrue , ResValue (noLoc typePBool))
|
||||
, (cPFalse , ResValue (noLoc typePBool))
|
||||
, (cError , ResOper (Just (noLoc (mkFunType [typeStr] typeError))) Nothing) -- non-can. of empty set
|
||||
, (cLength , ResOper (Just (noLoc (mkFunType [typeTok] typeInt))) Nothing)
|
||||
, (cDrop , ResOper (Just (noLoc (mkFunType [typeInt,typeTok] typeTok))) Nothing)
|
||||
, (cTake , ResOper (Just (noLoc (mkFunType [typeInt,typeTok] typeTok))) Nothing)
|
||||
, (cTk , ResOper (Just (noLoc (mkFunType [typeInt,typeTok] typeTok))) Nothing)
|
||||
, (cDp , ResOper (Just (noLoc (mkFunType [typeInt,typeTok] typeTok))) Nothing)
|
||||
, (cEqInt , ResOper (Just (noLoc (mkFunType [typeInt,typeInt] typePBool))) Nothing)
|
||||
, (cLessInt , ResOper (Just (noLoc (mkFunType [typeInt,typeInt] typePBool))) Nothing)
|
||||
, (cPlus , ResOper (Just (noLoc (mkFunType [typeInt,typeInt] typeInt))) Nothing)
|
||||
, (cEqStr , ResOper (Just (noLoc (mkFunType [typeTok,typeTok] typePBool))) Nothing)
|
||||
, (cOccur , ResOper (Just (noLoc (mkFunType [typeTok,typeTok] typePBool))) Nothing)
|
||||
, (cOccurs , ResOper (Just (noLoc (mkFunType [typeTok,typeTok] typePBool))) Nothing)
|
||||
---- "read" ->
|
||||
, (cRead , ResOper (Just (noLoc (mkProd -- (P : Type) -> Tok -> P
|
||||
[(Explicit,varP,typePType),(Explicit,identW,typeStr)] (Vr varP) []))) Nothing)
|
||||
, (cShow , ResOper (Just (noLoc (mkProd -- (P : PType) -> P -> Tok
|
||||
[(Explicit,varP,typePType),(Explicit,identW,Vr varP)] typeStr []))) Nothing)
|
||||
, (cToStr , ResOper (Just (noLoc (mkProd -- (L : Type) -> L -> Str
|
||||
[(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)
|
||||
]
|
||||
where
|
||||
noLoc = L (0,0)
|
||||
|
||||
varL :: Ident
|
||||
varL = identC (BS.pack "L")
|
||||
|
||||
varP :: Ident
|
||||
varP = identC (BS.pack "P")
|
||||
|
||||
appPredefined :: Term -> Err (Term,Bool)
|
||||
appPredefined t = case t of
|
||||
|
||||
@@ -70,7 +70,9 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
|
||||
inferLType :: SourceGrammar -> Context -> Term -> Check (Term, Type)
|
||||
inferLType gr g trm = case trm of
|
||||
|
||||
Q (m,ident) | isPredef m -> termWith trm $ checkErr (typPredefined ident)
|
||||
Q (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
|
||||
Just ty -> return ty
|
||||
Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident)
|
||||
|
||||
Q ident -> checks [
|
||||
termWith trm $ checkErr (lookupResType gr ident) >>= computeLType gr g
|
||||
@@ -80,7 +82,9 @@ inferLType gr g trm = case trm of
|
||||
checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
|
||||
]
|
||||
|
||||
QC (m,ident) | isPredef m -> termWith trm $ checkErr (typPredefined ident)
|
||||
QC (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
|
||||
Just ty -> return ty
|
||||
Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident)
|
||||
|
||||
QC ident -> checks [
|
||||
termWith trm $ checkErr (lookupResType gr ident) >>= computeLType gr g
|
||||
|
||||
Reference in New Issue
Block a user