diff --git a/src/compiler/GF/Compile/Compute/AppPredefined.hs b/src/compiler/GF/Compile/Compute/AppPredefined.hs index 0d23f8cb6..6b125e001 100644 --- a/src/compiler/GF/Compile/Compute/AppPredefined.hs +++ b/src/compiler/GF/Compile/Compute/AppPredefined.hs @@ -16,7 +16,7 @@ module GF.Compile.Compute.AppPredefined ( isInPredefined, typPredefined, arrityPredefined, predefModInfo, appPredefined ) where ---import GF.Infra.Ident(identS) +import GF.Compile.TypeCheck.Primitives import GF.Infra.Option import GF.Data.Operations import GF.Grammar @@ -31,13 +31,6 @@ import Data.Char (isUpper,toUpper,toLower) isInPredefined :: Ident -> Bool isInPredefined f = Map.member f primitives -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 - arrityPredefined :: Ident -> Maybe Int arrityPredefined f = do ty <- typPredefined f let (ctxt,_) = typeFormCnc ty @@ -46,56 +39,6 @@ arrityPredefined f = do ty <- typPredefined f predefModInfo :: SourceModInfo predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" Nothing primitives -primitives = Map.fromList - [ (cErrorType, ResOper (Just (noLoc typeType)) Nothing) - , (cInt , ResOper (Just (noLoc typePType)) Nothing) - , (cFloat , ResOper (Just (noLoc typePType)) Nothing) - , (cInts , fun [typeInt] typePType) - , (cPBool , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)])) - , (cPTrue , ResValue (noLoc typePBool)) - , (cPFalse , ResValue (noLoc typePBool)) - , (cError , fun [typeStr] typeError) -- non-can. of empty set - , (cLength , fun [typeTok] typeInt) - , (cDrop , fun [typeInt,typeTok] typeTok) - , (cTake , fun [typeInt,typeTok] typeTok) - , (cTk , fun [typeInt,typeTok] typeTok) - , (cDp , fun [typeInt,typeTok] typeTok) - , (cEqInt , fun [typeInt,typeInt] typePBool) - , (cLessInt , fun [typeInt,typeInt] typePBool) - , (cPlus , fun [typeInt,typeInt] typeInt) - , (cEqStr , fun [typeTok,typeTok] typePBool) - , (cOccur , fun [typeTok,typeTok] typePBool) - , (cOccurs , fun [typeTok,typeTok] typePBool) - - , (cToUpper , fun [typeTok] typeTok) - , (cToLower , fun [typeTok] typeTok) - , (cIsUpper , fun [typeTok] typePBool) - ----- "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) - , (cEqVal , ResOper (Just (noLoc (mkProd -- (P : PType) -> P -> P -> PBool - [(Explicit,varP,typePType),(Explicit,identW,Vr varP),(Explicit,identW,Vr varP)] typePBool []))) 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) - , (cNonExist , ResOper (Just (noLoc (mkProd -- Str - [] typeStr []))) Nothing) - , (cBIND , ResOper (Just (noLoc (mkProd -- Str - [] typeStr []))) Nothing) - , (cSOFT_BIND, ResOper (Just (noLoc (mkProd -- Str - [] typeStr []))) Nothing) - ] - where - fun from to = oper (mkFunType from to) - oper ty = ResOper (Just (noLoc ty)) Nothing - - varL = identS "L" - varP = identS "P" - appPredefined :: Term -> Err (Term,Bool) appPredefined t = case t of App f x0 -> do diff --git a/src/compiler/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/GF/Compile/TypeCheck/Concrete.hs index f13da4e01..61600da28 100644 --- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs +++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs @@ -9,7 +9,7 @@ import GF.Grammar.Lookup import GF.Grammar.Predef import GF.Grammar.PatternMatch import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord) -import GF.Compile.Compute.AppPredefined +import GF.Compile.TypeCheck.Primitives import Data.List import Control.Monad diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs index 301f1da0b..7f78e4c40 100644 --- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs @@ -5,7 +5,7 @@ import GF.Grammar.Lookup import GF.Grammar.Predef import GF.Grammar.Lockfield import GF.Compile.Compute.ConcreteNew1 -import GF.Compile.Compute.AppPredefined +import GF.Compile.TypeCheck.Primitives import GF.Infra.CheckM --import GF.Infra.UseIO import GF.Data.Operations diff --git a/src/compiler/GF/Compile/TypeCheck/Primitives.hs b/src/compiler/GF/Compile/TypeCheck/Primitives.hs new file mode 100644 index 000000000..bf3d92b24 --- /dev/null +++ b/src/compiler/GF/Compile/TypeCheck/Primitives.hs @@ -0,0 +1,62 @@ +module GF.Compile.TypeCheck.Primitives where + +import GF.Grammar +import GF.Grammar.Predef +import qualified Data.Map as Map + +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 + +primitives = Map.fromList + [ (cErrorType, ResOper (Just (noLoc typeType)) Nothing) + , (cInt , ResOper (Just (noLoc typePType)) Nothing) + , (cFloat , ResOper (Just (noLoc typePType)) Nothing) + , (cInts , fun [typeInt] typePType) + , (cPBool , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)])) + , (cPTrue , ResValue (noLoc typePBool)) + , (cPFalse , ResValue (noLoc typePBool)) + , (cError , fun [typeStr] typeError) -- non-can. of empty set + , (cLength , fun [typeTok] typeInt) + , (cDrop , fun [typeInt,typeTok] typeTok) + , (cTake , fun [typeInt,typeTok] typeTok) + , (cTk , fun [typeInt,typeTok] typeTok) + , (cDp , fun [typeInt,typeTok] typeTok) + , (cEqInt , fun [typeInt,typeInt] typePBool) + , (cLessInt , fun [typeInt,typeInt] typePBool) + , (cPlus , fun [typeInt,typeInt] typeInt) + , (cEqStr , fun [typeTok,typeTok] typePBool) + , (cOccur , fun [typeTok,typeTok] typePBool) + , (cOccurs , fun [typeTok,typeTok] typePBool) + + , (cToUpper , fun [typeTok] typeTok) + , (cToLower , fun [typeTok] typeTok) + , (cIsUpper , fun [typeTok] typePBool) + +---- "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) + , (cEqVal , ResOper (Just (noLoc (mkProd -- (P : PType) -> P -> P -> PBool + [(Explicit,varP,typePType),(Explicit,identW,Vr varP),(Explicit,identW,Vr varP)] typePBool []))) 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) + , (cNonExist , ResOper (Just (noLoc (mkProd -- Str + [] typeStr []))) Nothing) + , (cBIND , ResOper (Just (noLoc (mkProd -- Str + [] typeStr []))) Nothing) + , (cSOFT_BIND, ResOper (Just (noLoc (mkProd -- Str + [] typeStr []))) Nothing) + ] + where + fun from to = oper (mkFunType from to) + oper ty = ResOper (Just (noLoc ty)) Nothing + + varL = identS "L" + varP = identS "P"