forked from GitHub/gf-core
5e091d2e3d
* Evaluate operators once, not every time they are looked up * Remember the list of parameter values instead of recomputing it from the pattern type every time a table selection is made. * Quick fix for partial application of some predefined functions.
94 lines
3.1 KiB
Haskell
94 lines
3.1 KiB
Haskell
-- | 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
|