forked from GitHub/gf-core
Move typePredefined from GF.Compile.Compute.AppPredefined to GF.Compile.TypeCheck.Primitives
Also move the list of primitives
This commit is contained in:
hallgren
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
62
src/compiler/GF/Compile/TypeCheck/Primitives.hs
Normal file
62
src/compiler/GF/Compile/TypeCheck/Primitives.hs
Normal file
@@ -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"
|
||||
Reference in New Issue
Block a user