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

2 files changed, 69 insertions, 44 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
diff --git a/src/compiler/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/GF/Compile/TypeCheck/Concrete.hs
index a36e17aad..0f7f9b340 100644
--- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs
@@ -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 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 [
      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)
      ]
 
-   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 [
        termWith trm $ checkErr (lookupResType gr ident) >>= computeLType gr g