diff options
Diffstat (limited to 'src/compiler/GF/Compile/Compute')
| -rw-r--r-- | src/compiler/GF/Compile/Compute/AppPredefined.hs | 105 |
1 files changed, 63 insertions, 42 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 - -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)) - -varL :: Ident -varL = identC (BS.pack "L") - -varP :: Ident -varP = identC (BS.pack "P") +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 + return (length ctxt) + +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 |