GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 19:42:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

the abstract syntax for Predef.gf is now hard-coded in AppPredefined.hs

Browse Source
This commit is contained in:
krasimir
2010-07-01 15:38:16 +00:00
parent e0231cbf5b
commit 710b8f1bf7
2 changed files with 66 additions and 41 deletions
Download Patch File Download Diff File Expand all files Collapse all files

99
src/compiler/GF/Compile/Compute/AppPredefined.hs
View File

@@ -12,58 +12,79 @@
-- Predefined function type signatures and definitions. -- Predefined function type signatures and definitions.
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Compile.Compute.AppPredefined (isInPredefined, typPredefined, appPredefined module GF.Compile.Compute.AppPredefined (
) where isInPredefined, typPredefined, arrityPredefined, predefModInfo, appPredefined
) where
import GF.Infra.Ident import GF.Infra.Ident
import GF.Infra.Modules
import GF.Infra.Option
import GF.Data.Operations import GF.Data.Operations
import GF.Grammar
import GF.Grammar.Predef import GF.Grammar.Predef
import GF.Grammar.Grammar
import GF.Grammar.Macros import qualified Data.Map as Map
import GF.Grammar.Printer
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import Text.PrettyPrint import Text.PrettyPrint
-- predefined function type signatures and definitions. AR 12/3/2003. -- predefined function type signatures and definitions. AR 12/3/2003.
isInPredefined :: Ident -> Bool isInPredefined :: Ident -> Bool
isInPredefined = err (const True) (const False) . typPredefined isInPredefined f = Map.member f primitives
typPredefined :: Ident -> Err Type typPredefined :: Ident -> Maybe Type
typPredefined f typPredefined f = case Map.lookup f primitives of
| f == cInt = return typePType Just (ResOper (Just (L _ ty)) _) -> Just ty
| f == cFloat = return typePType Just (ResParam _ _) -> Just typePType
| f == cErrorType = return typeType Just (ResValue (L _ ty)) -> Just ty
| f == cInts = return $ mkFunType [typeInt] typePType _ -> Nothing
| 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 arrityPredefined :: Ident -> Maybe Int
varL = identC (BS.pack "L") arrityPredefined f = do ty <- typPredefined f
let (ctxt,_) = typeFormCnc ty
return (length ctxt)
varP :: Ident predefModInfo :: SourceModInfo
varP = identC (BS.pack "P") 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 :: Term -> Err (Term,Bool)
appPredefined t = case t of appPredefined t = case t of

8
src/compiler/GF/Compile/TypeCheck/Concrete.hs
View File

@@ -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 :: SourceGrammar -> Context -> Term -> Check (Term, Type)
inferLType gr g trm = case trm of 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 [ Q ident -> checks [
termWith trm $ checkErr (lookupResType gr ident) >>= computeLType gr g 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) 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 [ QC ident -> checks [
termWith trm $ checkErr (lookupResType gr ident) >>= computeLType gr g termWith trm $ checkErr (lookupResType gr ident) >>= computeLType gr g