1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
-- | Implementations of predefined functions
module GF.Compile.Compute.Predef where
import Text.PrettyPrint(render,hang,text)
import qualified Data.Map as Map
import Data.List (isInfixOf)
import Data.Char (isUpper,toLower,toUpper)
import GF.Data.Utilities (mapSnd,apBoth)
import GF.Compile.Compute.Value
import GF.Infra.Ident (Ident,varX)
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!!!
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
apSB f vs = case vs of
[VString s] -> boolV (f s)
_ -> bug $ "f::Str->Bool got "++show vs
apSS f vs = case vs of
[VString s] -> string (f s)
_ -> bug $ "f::Str->Str got "++show vs
apSS' f vs = case vs of
[VString s] -> f s
_ -> bug $ "f::Str->_ got "++show vs
boolV b = VCApp (cPredef,if b then cPTrue else cPFalse) []
strictf f vs = case normvs vs of
Left err -> VError err
Right vs -> f vs
normvs = mapM (strict . norm)
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
string s = case words s of
[] -> VString ""
ss -> foldr1 VC (map VString ss)
---
bug msg = ppbug (text msg)
ppbug doc = error $ render $
hang (text "Internal error in Compute.Predef:") 4 doc
|
