From 51e4f36b80626f045802d87096737a845fed95d6 Mon Sep 17 00:00:00 2001 From: krasimir Date: Thu, 1 Jul 2010 15:38:16 +0000 Subject: [PATCH] the abstract syntax for Predef.gf is now hard-coded in AppPredefined.hs --- .../GF/Compile/Compute/AppPredefined.hs | 99 +++++++++++-------- src/compiler/GF/Compile/TypeCheck/Concrete.hs | 8 +- 2 files changed, 66 insertions(+), 41 deletions(-) diff --git a/src/compiler/GF/Compile/Compute/AppPredefined.hs b/src/compiler/GF/Compile/Compute/AppPredefined.hs index 94dc67022..bbc28a05e 100644 --- a/src/compiler/GF/Compile/Compute/AppPredefined.hs +++ b/src/compiler/GF/Compile/Compute/AppPredefined.hs @@ -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 diff --git a/src/compiler/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/GF/Compile/TypeCheck/Concrete.hs index a36e17aad..0f7f9b340 100644 --- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs +++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs @@ -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