Skip to content

Commit 19c5b41

Browse files
phantamanta44phantamanta44
committed
Predef combinators
1 parent 815dfcc commit 19c5b41

File tree

2 files changed

+103
-34
lines changed

2 files changed

+103
-34
lines changed

‎src/compiler/api/GF/Compile/Compute/Concrete.hs‎

Lines changed: 94 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,13 @@
1-
{-# LANGUAGE RankNTypes, BangPatterns, CPP, ExistentialQuantification #-}
1+
{-# LANGUAGE RankNTypes, BangPatterns, CPP, ExistentialQuantification, LambdaCase #-}
22

33
-- | Functions for computing the values of terms in the concrete syntax, in
44
-- | preparation for PMCFG generation.
55
module GF.Compile.Compute.Concrete
66
( normalForm, normalFlatForm, normalStringForm
77
, Value(..), Thunk, ThunkState(..), Env, Scope, showValue
8-
, MetaThunks, Constraint, Globals(..), ConstValue(..)
8+
, PredefImpl, Predef(..), PredefCombinator, ($\)
9+
, pdForce, pdClosedArgs, pdArity, pdStandard
10+
, MetaThunks, Constraint, PredefTable, Globals(..), ConstValue(..)
911
, EvalM(..), runEvalM, runEvalOneM, reset, evalError, evalWarn
1012
, eval, apply, force, value2term, patternMatch, stdPredef
1113
, unsafeIOToEvalM
@@ -26,7 +28,7 @@ import GF.Grammar.Predef
2628
import GF.Grammar.Lockfield(lockLabel)
2729
import GF.Grammar.Printer
2830
import GF.Data.Operations(Err(..))
29-
import GF.Data.Utilities((<||>),anyM)
31+
import GF.Data.Utilities(splitAt',(<||>),anyM)
3032
import GF.Infra.CheckM
3133
import GF.Infra.Option
3234
import Data.STRef
@@ -238,15 +240,12 @@ eval env (S t1 t2) vs = do v1 <- eval env t1 []
238240
v1 -> return v0
239241
eval env (Let (x,(_,t1)) t2) vs = do tnk <- newThunk env t1
240242
eval ((x,tnk):env) t2 vs
241-
eval env (Q q@(m,id)) vs
242-
| m == cPredef = do vs' <- mapM force vs -- FIXME this does not allow for partial application!
243-
open <- anyM (value2term True [] >=> isOpen []) vs'
244-
if open then return (VApp q vs) else do
245-
res <- evalPredef id vs'
246-
case res of
247-
Const res -> return res
248-
RunTime -> return (VApp q vs)
249-
NonExist -> return (VApp (cPredef,cNonExist) [])
243+
eval env t@(Q q@(m,id)) vs
244+
| m == cPredef = do res <- evalPredef env t id vs
245+
case res of
246+
Const res -> return res
247+
RunTime -> return (VApp q vs)
248+
NonExist -> return (VApp (cPredef,cNonExist) [])
250249
| otherwise = do t <- getResDef q
251250
eval env t vs
252251
eval env (QC q) vs = return (VApp q vs)
@@ -326,25 +325,25 @@ apply (VClosure env (Abs b x t)) (v:vs) = eval ((x,v):env) t vs
326325
apply v [] = return v
327326

328327

329-
stdPredef :: Map.Map Ident ([Value s] -> EvalM s (ConstValue (Value s)))
328+
stdPredef :: PredefTable s
330329
stdPredef = Map.fromList
331-
[(cLength, \[v] -> case value2string v of
332-
Const s -> return (Const (VInt (genericLength s)))
333-
_ -> return RunTime)
334-
,(cTake, \[v1,v2] -> return (fmap string2value (liftA2 genericTake (value2int v1) (value2string v2))))
335-
,(cDrop, \[v1,v2] -> return (fmap string2value (liftA2 genericDrop (value2int v1) (value2string v2))))
336-
,(cTk, \[v1,v2] -> return (fmap string2value (liftA2 genericTk (value2int v1) (value2string v2))))
337-
,(cDp, \[v1,v2] -> return (fmap string2value (liftA2 genericDp (value2int v1) (value2string v2))))
338-
,(cIsUpper,\[v] -> return (fmap toPBool (liftA (all isUpper) (value2string v))))
339-
,(cToUpper,\[v] -> return (fmap string2value (liftA (map toUpper) (value2string v))))
340-
,(cToLower,\[v] -> return (fmap string2value (liftA (map toLower) (value2string v))))
341-
,(cEqStr, \[v1,v2] -> return (fmap toPBool (liftA2 (==) (value2string v1) (value2string v2))))
342-
,(cOccur, \[v1,v2] -> return (fmap toPBool (liftA2 occur (value2string v1) (value2string v2))))
343-
,(cOccurs, \[v1,v2] -> return (fmap toPBool (liftA2 occurs (value2string v1) (value2string v2))))
344-
,(cEqInt, \[v1,v2] -> return (fmap toPBool (liftA2 (==) (value2int v1) (value2int v2))))
345-
,(cLessInt,\[v1,v2] -> return (fmap toPBool (liftA2 (<) (value2int v1) (value2int v2))))
346-
,(cPlus, \[v1,v2] -> return (fmap VInt (liftA2 (+) (value2int v1) (value2int v2))))
347-
,(cError, \[v] -> case value2string v of
330+
[(cLength, pdStandard 1 $\ \[v] -> case value2string v of
331+
Const s -> return (Const (VInt (genericLength s)))
332+
_ -> return RunTime)
333+
,(cTake, pdStandard 2 $\ \[v1,v2] -> return (fmap string2value (liftA2 genericTake (value2int v1) (value2string v2))))
334+
,(cDrop, pdStandard 2 $\ \[v1,v2] -> return (fmap string2value (liftA2 genericDrop (value2int v1) (value2string v2))))
335+
,(cTk, pdStandard 2 $\ \[v1,v2] -> return (fmap string2value (liftA2 genericTk (value2int v1) (value2string v2))))
336+
,(cDp, pdStandard 2 $\ \[v1,v2] -> return (fmap string2value (liftA2 genericDp (value2int v1) (value2string v2))))
337+
,(cIsUpper,pdStandard 1 $\ \[v] -> return (fmap toPBool (liftA (all isUpper) (value2string v))))
338+
,(cToUpper,pdStandard 1 $\ \[v] -> return (fmap string2value (liftA (map toUpper) (value2string v))))
339+
,(cToLower,pdStandard 1 $\ \[v] -> return (fmap string2value (liftA (map toLower) (value2string v))))
340+
,(cEqStr, pdStandard 2 $\ \[v1,v2] -> return (fmap toPBool (liftA2 (==) (value2string v1) (value2string v2))))
341+
,(cOccur, pdStandard 2 $\ \[v1,v2] -> return (fmap toPBool (liftA2 occur (value2string v1) (value2string v2))))
342+
,(cOccurs, pdStandard 2 $\ \[v1,v2] -> return (fmap toPBool (liftA2 occurs (value2string v1) (value2string v2))))
343+
,(cEqInt, pdStandard 2 $\ \[v1,v2] -> return (fmap toPBool (liftA2 (==) (value2int v1) (value2int v2))))
344+
,(cLessInt,pdStandard 2 $\ \[v1,v2] -> return (fmap toPBool (liftA2 (<) (value2int v1) (value2int v2))))
345+
,(cPlus, pdStandard 2 $\ \[v1,v2] -> return (fmap VInt (liftA2 (+) (value2int v1) (value2int v2))))
346+
,(cError, pdStandard 1 $\ \[v] -> case value2string v of
348347
Const msg -> fail msg
349348
_ -> fail "Indescribable error appeared")
350349
]
@@ -705,6 +704,16 @@ instance Applicative ConstValue where
705704
liftA2 f _ RunTime = RunTime
706705
#endif
707706

707+
instance Foldable ConstValue where
708+
foldr f a (Const x) = f x a
709+
foldr f a RunTime = a
710+
foldr f a NonExist = a
711+
712+
instance Traversable ConstValue where
713+
traverse f (Const x) = Const <$> f x
714+
traverse f RunTime = pure RunTime
715+
traverse f NonExist = pure NonExist
716+
708717
value2string v = fmap (\(_,ws,_) -> unwords ws) (value2string' v False [] [])
709718

710719
value2string' (VStr w1) True (w2:ws) qs = Const (False,(w1++w2):ws,qs)
@@ -762,12 +771,63 @@ string2value' (w:ws) = VC (VStr w) (string2value' ws)
762771
value2int (VInt n) = Const n
763772
value2int _ = RunTime
764773

774+
-----------------------------------------------------------------------
775+
-- * Global/built-in definitions
776+
777+
type PredefImpl a s = [a] -> EvalM s (ConstValue (Value s))
778+
newtype Predef a s = Predef { runPredef :: Term -> Env s -> PredefImpl a s }
779+
type PredefCombinator a b s = Predef a s -> Predef b s
780+
781+
infix 0 $\\
782+
783+
($\) :: PredefCombinator a b s -> PredefImpl a s -> Predef b s
784+
k $\ f = k (Predef (\_ _ -> f))
785+
786+
pdForce :: PredefCombinator (Value s) (Thunk s) s
787+
pdForce def = Predef $ \h env args -> do
788+
argValues <- mapM force args
789+
runPredef def h env argValues
790+
791+
pdClosedArgs :: PredefCombinator (Value s) (Value s) s
792+
pdClosedArgs def = Predef $ \h env args -> do
793+
open <- anyM (value2term True [] >=> isOpen []) args
794+
if open then return RunTime else runPredef def h env args
795+
796+
pdArity :: Int -> PredefCombinator (Thunk s) (Thunk s) s
797+
pdArity n def = Predef $ \h env args ->
798+
case splitAt' n args of
799+
Nothing -> do
800+
t <- papply env h args
801+
let t' = abstract 0 (n - length args) t
802+
Const <$> eval env t' []
803+
Just (usedArgs, remArgs) -> do
804+
res <- runPredef def h env usedArgs
805+
forM res $ \v -> case remArgs of
806+
[] -> return v
807+
_ -> do
808+
t <- value2term False (fst <$> env) v
809+
eval env t remArgs
810+
where
811+
papply env t [] = return t
812+
papply env t (arg:args) = do
813+
arg <- tnk2term False (fst <$> env) arg
814+
papply env (App t arg) args
815+
816+
abstract i n t
817+
| n <= 0 = t
818+
| otherwise = let x = identV (rawIdentS "a") i
819+
in Abs Explicit x (abstract (i + 1) (n - 1) (App t (Vr x)))
820+
821+
pdStandard :: Int -> PredefCombinator (Value s) (Thunk s) s
822+
pdStandard n = pdArity n . pdForce . pdClosedArgs
823+
765824
-----------------------------------------------------------------------
766825
-- * Evaluation monad
767826

768827
type MetaThunks s = Map.Map MetaId (Thunk s)
769828
type Cont s r = MetaThunks s -> Int -> r -> [Message] -> ST s (CheckResult r [Message])
770-
data Globals = Gl Grammar (forall s . Map.Map Ident ([Value s] -> EvalM s (ConstValue (Value s))))
829+
type PredefTable s = Map.Map Ident (Predef (Thunk s) s)
830+
data Globals = Gl Grammar (forall s . PredefTable s)
771831
newtype EvalM s a = EvalM (forall r . Globals -> (a -> Cont s r) -> Cont s r)
772832

773833
instance Functor (EvalM s) where
@@ -826,9 +886,9 @@ evalError msg = EvalM (\gr k _ _ r msgs -> return (Fail msg msgs))
826886
evalWarn :: Message -> EvalM s ()
827887
evalWarn msg = EvalM (\gr k mt d r msgs -> k () mt d r (msg:msgs))
828888

829-
evalPredef :: Ident -> [Value s] -> EvalM s (ConstValue (Value s))
830-
evalPredef id vs = EvalM (\globals@(Gl _ predef) k mt d r msgs ->
831-
case fmap (\f -> f vs) (Map.lookup id predef) of
889+
evalPredef :: Env s -> Term -> Ident -> [Thunk s] -> EvalM s (ConstValue (Value s))
890+
evalPredef env h id args = EvalM (\globals@(Gl _ predef) k mt d r msgs ->
891+
case fmap (\def -> runPredef def h env args) (Map.lookup id predef) of
832892
Just (EvalM f) -> f globals k mt d r msgs
833893
Nothing -> k RunTime mt d r msgs)
834894

‎src/compiler/api/GF/Data/Utilities.hs‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@
1414

1515
module GF.Data.Utilities(module GF.Data.Utilities) where
1616

17+
import Data.Bifunctor (first)
1718
import Data.Maybe
1819
import Data.List
1920
import Control.Monad (MonadPlus(..),foldM,liftM,when)
@@ -45,6 +46,14 @@ splitBy p [] = ([], [])
4546
splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys)
4647
where (xs, ys) = splitBy p as
4748

49+
splitAt' :: Int -> [a] -> Maybe ([a], [a])
50+
splitAt' n xs
51+
| n <= 0 = Just ([], xs)
52+
| otherwise = helper n xs
53+
where helper 0 xs = Just ([], xs)
54+
helper n [] = Nothing
55+
helper n (x:xs) = first (x:) <$> helper (n - 1) xs
56+
4857
foldMerge :: (a -> a -> a) -> a -> [a] -> a
4958
foldMerge merge zero = fm
5059
where fm [] = zero

0 commit comments

Comments
 (0)