1 files changed, 113 insertions, 64 deletions

diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs
index e6fd6af7c..f37fd989f 100644
--- a/src/compiler/GF/Compile/Compute/Predef.hs
+++ b/src/compiler/GF/Compile/Compute/Predef.hs
@@ -1,93 +1,142 @@
 -- | Implementations of predefined functions
-module GF.Compile.Compute.Predef where
+{-# LANGUAGE FlexibleInstances #-}
+module GF.Compile.Compute.Predef(predef,predefName,delta) where
 
 import Text.PrettyPrint(render,hang,text)
 import qualified Data.Map as Map
+import Data.Array(array,(!))
 import Data.List (isInfixOf)
 import Data.Char (isUpper,toLower,toUpper)
+import Control.Monad(ap)
 
 import GF.Data.Utilities (mapSnd,apBoth)
 
 import GF.Compile.Compute.Value
-import GF.Infra.Ident (Ident,varX)
+import GF.Infra.Ident (Ident,varX,showIdent)
+import GF.Data.Operations(Err,err)
 import GF.Grammar.Predef
 import PGF.Data(BindType(..))
 
-predefs :: Map.Map Ident ([Value]->Value)
-predefs = Map.fromList $ mapSnd strictf
-    [(cDrop,apISS drop),(cTake,apISS take),(cTk,apISS tk),(cDp,apISS dp),
-     (cEqStr,apSSB (==)),(cOccur,apSSB occur),(cOccurs,apSSB occurs),
-     (cToUpper,apSS (map toUpper)),(cToLower,apSS (map toLower)),
-     (cIsUpper,apSB (all isUpper)),(cLength,apSS' (VInt . length)),
-     (cPlus,apIII (+)),(cEqInt,apIIB (==)),(cLessInt,apIIB (<)),
-     (cShow,unimpl),(cRead,unimpl),(cToStr,unimpl),(cMapStr,unimpl),
-     (cEqVal,unimpl),(cError,apSS' VError)]
-    --- add more functions!!!
+--------------------------------------------------------------------------------
+class Predef a where
+  toValue :: a -> Value
+  fromValue :: Value -> Err a
+
+instance Predef Int where
+  toValue = VInt
+  fromValue (VInt i) = return i
+  fromValue v = verror "Int" v
+
+instance Predef Bool where
+  toValue = boolV
+
+instance Predef String where
+  toValue = string
+  fromValue v = case norm v of
+                  VString s -> return s
+                  _ -> verror "String" v
+
+instance Predef Value where
+  toValue = id
+  fromValue = return
+{-
+instance (Predef a,Predef b) => Predef (a->b) where
+  toValue f = VAbs Explicit (varX 0) $ Bind $ err bug (toValue . f) . fromValue
+-}
+verror t v =
+  case v of
+    VError e -> fail e
+    VGen {}  -> fail $ "Expected a static value of type "++t
+                       ++", got a dynamic value"
+    _ -> fail $ "Expected a value of type "++t++", got "++show v
+
+--------------------------------------------------------------------------------
+
+predef f = maybe undef return (Map.lookup f predefs)
   where
-    unimpl = bug "unimplemented predefined function"
-
-    tk i s = take (max 0 (length s - i)) s
-    dp i s = drop (max 0 (length s - i)) s
-    occur s t = isInfixOf s t
-    occurs s t = any (`elem` t) s
-
-    apIII f vs = case vs of
-                   [VInt i1, VInt i2] -> VInt (f i1 i2)
-                   _ -> bug $ "f::Int->Int->Int got "++show vs
-
-    apIIB f vs = case vs of
-                   [VInt i1, VInt i2] -> boolV (f i1 i2)
-                   _ -> bug $ "f::Int->Int->Bool got "++show vs
-
-    apISS f vs = case vs of
-                   [VInt i, VString s] -> string (f i s)
-                   [VInt i] -> VAbs Explicit (varX 0) $ Bind $ \ v ->
-                               case norm v of
-                                 VString s -> string (f i s)
-                                 _ -> bug $ "f::Int->Str->Str got "++show (vs++[v])
-                   _ -> bug $ "f::Int->Str->Str got "++show vs
-
-    apSSB f vs = case vs of
-                   [VString s1, VString s2] -> boolV (f s1 s2)
-                   _ -> bug $ "f::Str->Str->Bool got "++show vs
+    undef = fail $ "Unimplemented predfined operator: Predef."++showIdent f
+
+predefs :: Map.Map Ident Predefined
+predefs = Map.fromList predefList
+
+predefName pre = predefNames ! pre
+predefNames = array (minBound,maxBound) (map swap predefList)
+
+predefList =
+    [(cDrop,Drop),(cTake,Take),(cTk,Tk),(cDp,Dp),(cEqStr,EqStr),
+     (cOccur,Occur),(cOccurs,Occurs),(cToUpper,ToUpper),(cToLower,ToLower),
+     (cIsUpper,IsUpper),(cLength,Length),(cPlus,Plus),(cEqInt,EqInt),
+     (cLessInt,LessInt),
+     -- cShow, cRead, cMapStr, cEqVal
+     (cError,Error),
+     -- Canonical values:
+     (cPBool,PBool),(cPFalse,PFalse),(cPTrue,PTrue),(cInts,Ints)]
+    --- add more functions!!!
 
-    apSB  f vs = case vs of
-                   [VString s] -> boolV (f s)
-                   _ -> bug $ "f::Str->Bool got "++show vs
+delta f vs =
+    case f of
+      Drop    -> ap2 (drop::Int->String->String)
+      Take    -> ap2 (take::Int->String->String)
+      Tk      -> ap2 tk
+      Dp      -> ap2 dp
+      EqStr   -> ap2 ((==)::String->String->Bool)
+      Occur   -> ap2 occur
+      Occurs  -> ap2 occurs
+      ToUpper -> ap1 (map toUpper)
+      ToLower -> ap1 (map toLower)
+      IsUpper -> ap1 (all isUpper)
+      Length  -> ap1 (length::String->Int)
+      Plus    -> ap2 ((+)::Int->Int->Int)
+      EqInt   -> ap2 ((==)::Int->Int->Bool)
+      LessInt -> ap2 ((<)::Int->Int->Bool)
+    {- | Show | Read | ToStr | MapStr | EqVal -}
+      Error   -> ap1 VError
+      -- Canonical values:
+      PBool   -> canonical
+      Ints    -> canonical
+      PFalse  -> canonical
+      PTrue   -> canonical
+  where
+    canonical = delay
+    delay = return (VApp f vs) -- wrong number of arguments
 
-    apSS  f vs = case vs of
-                   [VString s] -> string (f s)
-                   _ -> bug $ "f::Str->Str got "++show vs
+    ap1 f = case vs of
+              [v1] -> (toValue . f) `fmap` fromValue v1
+              _ -> delay
 
-    apSS' f vs = case vs of
-                   [VString s] -> f s
-                   _ -> bug $ "f::Str->_ got "++show vs
+    ap2 f = case vs of
+             [v1,v2] -> toValue `fmap` (f `fmap` fromValue v1 `ap` fromValue v2)
+             _ -> delay
 
-    boolV b = VCApp (cPredef,if b then cPTrue else cPFalse) []
+    unimpl id = bug $ "unimplemented predefined function: "++showIdent id
+--  problem id vs = bug $ "unexpected arguments: Predef."++showIdent id++" "++show vs
 
-    strictf f vs = case normvs vs of
-                     Left err -> VError err
-                     Right vs -> f vs
+    tk i s = take (max 0 (length s - i)) s :: String
+    dp i s = drop (max 0 (length s - i)) s :: String
+    occur s t = isInfixOf (s::String) t
+    occurs s t = any (`elem` t) (s::String)
 
-    normvs = mapM (strict . norm)
+boolV b = VCApp (cPredef,if b then cPTrue else cPFalse) []
 
-    norm v =
-      case v of
-        VC v1 v2 -> case apBoth norm (v1,v2) of
-                      (VString s1,VString s2) -> VString (s1++" "++s2)
-                      (v1,v2) -> VC v1 v2
-        _ -> v
+norm v =
+  case v of
+    VC v1 v2 -> case apBoth norm (v1,v2) of
+                  (VString s1,VString s2) -> VString (s1++" "++s2)
+                  (v1,v2) -> VC v1 v2
+    _ -> v
 
-    strict v = case v of
-                 VError err -> Left err
-                 _ -> Right v
+strict v = case v of
+             VError err -> Left err
+             _ -> Right v
 
-    string s = case words s of
-                 [] -> VString ""
-                 ss -> foldr1 VC (map VString ss)
+string s = case words s of
+             [] -> VString ""
+             ss -> foldr1 VC (map VString ss)
 
 ---
 
+swap (x,y) = (y,x)
+
 bug msg = ppbug (text msg)
 ppbug doc = error $ render $
                     hang (text "Internal error in Compute.Predef:") 4 doc