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)
  , (cSOFT_SPACE,ResOper (Just (noLoc (mkProd -- Str
                                         [] typeStr []))) Nothing)
  , (cCAPIT    , ResOper (Just (noLoc (mkProd -- Str
                                         [] typeStr []))) Nothing)
  , (cALL_CAPIT, 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"