-- | Implementations of predefined functions
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module GF.Compile.Compute.Predef(predef,predefName,delta) where

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 (apBoth) --mapSnd

import GF.Compile.Compute.Value
import GF.Infra.Ident (Ident,showIdent) --,varX
import GF.Data.Operations(Err) -- ,err
import GF.Grammar.Predef

--------------------------------------------------------------------------------
class Predef a where
  toValue :: a -> Value
  fromValue :: Value -> Err a

instance Predef Int where
  toValue :: Int -> Value
toValue = Int -> Value
VInt
  fromValue :: Value -> Err Int
fromValue (VInt Int
i) = Int -> Err Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
  fromValue Value
v = [Char] -> Value -> Err Int
forall (m :: * -> *) a. MonadFail m => [Char] -> Value -> m a
verror [Char]
"Int" Value
v

instance Predef Bool where
  toValue :: Bool -> Value
toValue = Bool -> Value
boolV
  fromValue :: Value -> Err Bool
fromValue Value
v = case Value
v of
    VCApp (ModuleName
mn,Ident
i) [] | ModuleName
mn ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
cPredef Bool -> Bool -> Bool
&& Ident
i Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
cPTrue -> Bool -> Err Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    VCApp (ModuleName
mn,Ident
i) [] | ModuleName
mn ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
cPredef Bool -> Bool -> Bool
&& Ident
i Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
cPFalse -> Bool -> Err Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Value
_ -> [Char] -> Value -> Err Bool
forall (m :: * -> *) a. MonadFail m => [Char] -> Value -> m a
verror [Char]
"Bool" Value
v

instance Predef String where
  toValue :: [Char] -> Value
toValue = [Char] -> Value
string
  fromValue :: Value -> Err [Char]
fromValue Value
v = case Value -> Value
norm Value
v of
                  VString [Char]
s -> [Char] -> Err [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
s
                  Value
_ -> [Char] -> Value -> Err [Char]
forall (m :: * -> *) a. MonadFail m => [Char] -> Value -> m a
verror [Char]
"String" Value
v

instance Predef Value where
  toValue :: Value -> Value
toValue = Value -> Value
forall a. a -> a
id
  fromValue :: Value -> Err Value
fromValue = Value -> Err Value
forall (m :: * -> *) a. Monad m => a -> m a
return

instance Predef Predefined where
  toValue :: Predefined -> Value
toValue Predefined
p = Predefined -> [Value] -> Value
VApp Predefined
p []
  fromValue :: Value -> Err Predefined
fromValue Value
v = case Value
v of
                  VApp Predefined
p [Value]
_ -> Predefined -> Err Predefined
forall (m :: * -> *) a. Monad m => a -> m a
return Predefined
p
                  Value
_        -> [Char] -> Err Predefined
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Err Predefined) -> [Char] -> Err Predefined
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected a predefined constant, got something else"

{-
instance (Predef a,Predef b) => Predef (a->b) where
  toValue f = VAbs Explicit (varX 0) $ Bind $ err bug (toValue . f) . fromValue
-}
verror :: [Char] -> Value -> m a
verror [Char]
t Value
v =
  case Value
v of
    VError [Char]
e -> [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
e
    VGen {}  -> [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m a) -> [Char] -> m a
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected a static value of type "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
t
                       [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
", got a dynamic value"
    Value
_ -> [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m a) -> [Char] -> m a
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected a value of type "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
t[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
", got "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Value -> [Char]
forall a. Show a => a -> [Char]
show Value
v

--------------------------------------------------------------------------------

predef :: Ident -> m Predefined
predef Ident
f = m Predefined
-> (Predefined -> m Predefined) -> Maybe Predefined -> m Predefined
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m Predefined
forall a. m a
undef Predefined -> m Predefined
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident -> Map Ident Predefined -> Maybe Predefined
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ident
f Map Ident Predefined
predefs)
  where
    undef :: m a
undef = [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m a) -> [Char] -> m a
forall a b. (a -> b) -> a -> b
$ [Char]
"Unimplemented predfined operator: Predef."[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Ident -> [Char]
showIdent Ident
f

predefs :: Map.Map Ident Predefined
predefs :: Map Ident Predefined
predefs = [(Ident, Predefined)] -> Map Ident Predefined
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Ident, Predefined)]
predefList

predefName :: Predefined -> Ident
predefName Predefined
pre = Array Predefined Ident
predefNames Array Predefined Ident -> Predefined -> Ident
forall i e. Ix i => Array i e -> i -> e
! Predefined
pre
predefNames :: Array Predefined Ident
predefNames = (Predefined, Predefined)
-> [(Predefined, Ident)] -> Array Predefined Ident
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Predefined
forall a. Bounded a => a
minBound,Predefined
forall a. Bounded a => a
maxBound) (((Ident, Predefined) -> (Predefined, Ident))
-> [(Ident, Predefined)] -> [(Predefined, Ident)]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, Predefined) -> (Predefined, Ident)
forall b a. (b, a) -> (a, b)
swap [(Ident, Predefined)]
predefList)

predefList :: [(Ident, Predefined)]
predefList =
    [(Ident
cDrop,Predefined
Drop),(Ident
cTake,Predefined
Take),(Ident
cTk,Predefined
Tk),(Ident
cDp,Predefined
Dp),(Ident
cEqStr,Predefined
EqStr),
     (Ident
cOccur,Predefined
Occur),(Ident
cOccurs,Predefined
Occurs),(Ident
cToUpper,Predefined
ToUpper),(Ident
cToLower,Predefined
ToLower),
     (Ident
cIsUpper,Predefined
IsUpper),(Ident
cLength,Predefined
Length),(Ident
cPlus,Predefined
Plus),(Ident
cEqInt,Predefined
EqInt),
     (Ident
cLessInt,Predefined
LessInt),
     -- cShow, cRead, cMapStr, cEqVal
     (Ident
cError,Predefined
Error),(Ident
cTrace,Predefined
Trace),
     -- Canonical values:
     (Ident
cPBool,Predefined
PBool),(Ident
cPFalse,Predefined
PFalse),(Ident
cPTrue,Predefined
PTrue),(Ident
cInt,Predefined
Int),(Ident
cFloat,Predefined
Float),
     (Ident
cInts,Predefined
Ints),(Ident
cNonExist,Predefined
NonExist)
     ,(Ident
cBIND,Predefined
BIND),(Ident
cSOFT_BIND,Predefined
SOFT_BIND),(Ident
cSOFT_SPACE,Predefined
SOFT_SPACE)
     ,(Ident
cCAPIT,Predefined
CAPIT),(Ident
cALL_CAPIT,Predefined
ALL_CAPIT)]
    --- add more functions!!!

delta :: Predefined -> [Value] -> Err Value
delta Predefined
f [Value]
vs =
    case Predefined
f of
      Predefined
Drop    -> [Value] -> Predefined -> Err Value -> Err Value
forall (m :: * -> *) a.
(Monad m, Predef a) =>
[Value] -> a -> m Value -> m Value
fromNonExist [Value]
vs Predefined
NonExist ((Int -> [Char] -> [Char]) -> Err Value
forall a a a.
(Predef a, Predef a, Predef a) =>
(a -> a -> a) -> Err Value
ap2 (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop::Int->String->String))
      Predefined
Take    -> [Value] -> Predefined -> Err Value -> Err Value
forall (m :: * -> *) a.
(Monad m, Predef a) =>
[Value] -> a -> m Value -> m Value
fromNonExist [Value]
vs Predefined
NonExist ((Int -> [Char] -> [Char]) -> Err Value
forall a a a.
(Predef a, Predef a, Predef a) =>
(a -> a -> a) -> Err Value
ap2 (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take::Int->String->String))
      Predefined
Tk      -> [Value] -> Predefined -> Err Value -> Err Value
forall (m :: * -> *) a.
(Monad m, Predef a) =>
[Value] -> a -> m Value -> m Value
fromNonExist [Value]
vs Predefined
NonExist ((Int -> [Char] -> [Char]) -> Err Value
forall a a a.
(Predef a, Predef a, Predef a) =>
(a -> a -> a) -> Err Value
ap2 Int -> [Char] -> [Char]
tk)
      Predefined
Dp      -> [Value] -> Predefined -> Err Value -> Err Value
forall (m :: * -> *) a.
(Monad m, Predef a) =>
[Value] -> a -> m Value -> m Value
fromNonExist [Value]
vs Predefined
NonExist ((Int -> [Char] -> [Char]) -> Err Value
forall a a a.
(Predef a, Predef a, Predef a) =>
(a -> a -> a) -> Err Value
ap2 Int -> [Char] -> [Char]
dp)
      Predefined
EqStr   -> [Value] -> Predefined -> Err Value -> Err Value
forall (m :: * -> *) a.
(Monad m, Predef a) =>
[Value] -> a -> m Value -> m Value
fromNonExist [Value]
vs Predefined
PFalse   (([Char] -> [Char] -> Bool) -> Err Value
forall a a a.
(Predef a, Predef a, Predef a) =>
(a -> a -> a) -> Err Value
ap2 ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
(==)::String->String->Bool))
      Predefined
Occur   -> [Value] -> Predefined -> Err Value -> Err Value
forall (m :: * -> *) a.
(Monad m, Predef a) =>
[Value] -> a -> m Value -> m Value
fromNonExist [Value]
vs Predefined
PFalse   (([Char] -> [Char] -> Bool) -> Err Value
forall a a a.
(Predef a, Predef a, Predef a) =>
(a -> a -> a) -> Err Value
ap2 [Char] -> [Char] -> Bool
occur)
      Predefined
Occurs  -> [Value] -> Predefined -> Err Value -> Err Value
forall (m :: * -> *) a.
(Monad m, Predef a) =>
[Value] -> a -> m Value -> m Value
fromNonExist [Value]
vs Predefined
PFalse   (([Char] -> [Char] -> Bool) -> Err Value
forall a a a.
(Predef a, Predef a, Predef a) =>
(a -> a -> a) -> Err Value
ap2 [Char] -> [Char] -> Bool
occurs)
      Predefined
ToUpper -> [Value] -> Predefined -> Err Value -> Err Value
forall (m :: * -> *) a.
(Monad m, Predef a) =>
[Value] -> a -> m Value -> m Value
fromNonExist [Value]
vs Predefined
NonExist (([Char] -> [Char]) -> Err Value
forall a a. (Predef a, Predef a) => (a -> a) -> Err Value
ap1 ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper))
      Predefined
ToLower -> [Value] -> Predefined -> Err Value -> Err Value
forall (m :: * -> *) a.
(Monad m, Predef a) =>
[Value] -> a -> m Value -> m Value
fromNonExist [Value]
vs Predefined
NonExist (([Char] -> [Char]) -> Err Value
forall a a. (Predef a, Predef a) => (a -> a) -> Err Value
ap1 ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower))
      Predefined
IsUpper -> [Value] -> Predefined -> Err Value -> Err Value
forall (m :: * -> *) a.
(Monad m, Predef a) =>
[Value] -> a -> m Value -> m Value
fromNonExist [Value]
vs Predefined
PFalse   (([Char] -> Bool) -> Err Value
forall a a. (Predef a, Predef a) => (a -> a) -> Err Value
ap1 ((Char -> Bool) -> [Char] -> Bool
forall a. (a -> Bool) -> [a] -> Bool
all' Char -> Bool
isUpper))
      Predefined
Length  -> [Value] -> Int -> Err Value -> Err Value
forall (m :: * -> *) a.
(Monad m, Predef a) =>
[Value] -> a -> m Value -> m Value
fromNonExist [Value]
vs (Int
0::Int) (([Char] -> Int) -> Err Value
forall a a. (Predef a, Predef a) => (a -> a) -> Err Value
ap1 ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length::String->Int))
      Predefined
Plus    -> (Int -> Int -> Int) -> Err Value
forall a a a.
(Predef a, Predef a, Predef a) =>
(a -> a -> a) -> Err Value
ap2 (Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)::Int->Int->Int)
      Predefined
EqInt   -> (Int -> Int -> Bool) -> Err Value
forall a a a.
(Predef a, Predef a, Predef a) =>
(a -> a -> a) -> Err Value
ap2 (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==)::Int->Int->Bool)
      Predefined
LessInt -> (Int -> Int -> Bool) -> Err Value
forall a a a.
(Predef a, Predef a, Predef a) =>
(a -> a -> a) -> Err Value
ap2 (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
(<)::Int->Int->Bool)
    {- -- | Show | Read | ToStr | MapStr | EqVal -}
      Predefined
Error   -> ([Char] -> Value) -> Err Value
forall a a. (Predef a, Predef a) => (a -> a) -> Err Value
ap1 [Char] -> Value
VError
      Predefined
Trace   -> (Value -> Value -> Value) -> Err Value
forall a a a.
(Predef a, Predef a, Predef a) =>
(a -> a -> a) -> Err Value
ap2 Value -> Value -> Value
vtrace
      -- Canonical values:
      Predefined
PBool   -> Err Value
canonical
      Predefined
Int     -> Err Value
canonical
      Predefined
Float   -> Err Value
canonical
      Predefined
Ints    -> Err Value
canonical
      Predefined
PFalse  -> Err Value
canonical
      Predefined
PTrue   -> Err Value
canonical
      Predefined
NonExist-> Err Value
canonical
      Predefined
BIND    -> Err Value
canonical
      Predefined
SOFT_BIND->Err Value
canonical
      Predefined
SOFT_SPACE->Err Value
canonical
      Predefined
CAPIT   -> Err Value
canonical
      Predefined
ALL_CAPIT->Err Value
canonical
  where
    canonical :: Err Value
canonical = Err Value
delay
    delay :: Err Value
delay = Value -> Err Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Predefined -> [Value] -> Value
VApp Predefined
f [Value]
vs) -- wrong number of arguments

    ap1 :: (a -> a) -> Err Value
ap1 a -> a
f = case [Value]
vs of
              [v1] -> (a -> Value
forall a. Predef a => a -> Value
toValue (a -> Value) -> (a -> a) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f) (a -> Value) -> Err a -> Err Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Value -> Err a
forall a. Predef a => Value -> Err a
fromValue Value
v1
              [Value]
_ -> Err Value
delay

    ap2 :: (a -> a -> a) -> Err Value
ap2 a -> a -> a
f = case [Value]
vs of
             [v1,v2] -> a -> Value
forall a. Predef a => a -> Value
toValue (a -> Value) -> Err a -> Err Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (a -> a -> a
f (a -> a -> a) -> Err a -> Err (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Value -> Err a
forall a. Predef a => Value -> Err a
fromValue Value
v1 Err (a -> a) -> Err a -> Err a
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Value -> Err a
forall a. Predef a => Value -> Err a
fromValue Value
v2)
             [Value]
_ -> Err Value
delay

    fromNonExist :: [Value] -> a -> m Value -> m Value
fromNonExist [Value]
vs a
a m Value
b
      | [Value] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value
v | v :: Value
v@(VApp Predefined
NonExist [Value]
_) <- [Value]
vs] = m Value
b
      | Bool
otherwise                            = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Value
forall a. Predef a => a -> Value
toValue a
a)

    vtrace :: Value -> Value -> Value
    vtrace :: Value -> Value -> Value
vtrace Value
x Value
y = Value
y -- tracing is implemented elsewhere

--  unimpl id = bug $ "unimplemented predefined function: "++showIdent id
--  problem id vs = bug $ "unexpected arguments: Predef."++showIdent id++" "++show vs

    tk :: Int -> [Char] -> [Char]
tk Int
i [Char]
s = Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)) [Char]
s :: String
    dp :: Int -> [Char] -> [Char]
dp Int
i [Char]
s = Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)) [Char]
s :: String
    occur :: [Char] -> [Char] -> Bool
occur [Char]
s [Char]
t = [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf ([Char]
s::String) ([Char]
t::String)
    occurs :: [Char] -> [Char] -> Bool
occurs [Char]
s [Char]
t = (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
t::String)) ([Char]
s::String)
    all' :: (a -> Bool) -> [a] -> Bool
all' = forall a. (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all :: (a->Bool) -> [a] -> Bool

boolV :: Bool -> Value
boolV Bool
b = (ModuleName, Ident) -> [Value] -> Value
VCApp (ModuleName
cPredef,if Bool
b then Ident
cPTrue else Ident
cPFalse) []

norm :: Value -> Value
norm Value
v =
  case Value
v of
    VC Value
v1 Value
v2 -> case (Value -> Value) -> (Value, Value) -> (Value, Value)
forall a b. (a -> b) -> (a, a) -> (b, b)
apBoth Value -> Value
norm (Value
v1,Value
v2) of
                  (VString [Char]
s1,VString [Char]
s2) -> [Char] -> Value
VString ([Char]
s1[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
s2)
                  (Value
v1,Value
v2) -> Value -> Value -> Value
VC Value
v1 Value
v2
    Value
_ -> Value
v
{-
strict v = case v of
             VError err -> Left err
             _ -> Right v
-}
string :: [Char] -> Value
string [Char]
s = case [Char] -> [[Char]]
words [Char]
s of
             [] -> [Char] -> Value
VString [Char]
""
             [[Char]]
ss -> (Value -> Value -> Value) -> [Value] -> Value
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Value -> Value -> Value
VC (([Char] -> Value) -> [[Char]] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Value
VString [[Char]]
ss)

---

swap :: (b, a) -> (a, b)
swap (b
x,a
y) = (a
y,b
x)
{-
bug msg = ppbug msg
ppbug doc = error $ render $
                    hang "Internal error in Compute.Predef:" 4 doc
-}