{-# 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)
import GF.Compile.Compute.Value
import GF.Infra.Ident (Ident,showIdent)
import GF.Data.Operations(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"
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),
(Ident
cError,Predefined
Error),(Ident
cTrace,Predefined
Trace),
(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)]
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)
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
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)
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
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
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)