mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-24 12:02:50 -06:00
Type annotations for option labels + new bubble impl
This commit is contained in:
Eve
@@ -5,19 +5,20 @@ module GF.Compile.Compute.Concrete2
|
||||
ConstValue(..), ConstVariants(..), Globals(..), PredefTable, EvalM,
|
||||
mapVariants, mapVariantsC, unvariants, variants2consts,
|
||||
mapConstVs, mapConstVsC, unconstVs, consts2variants,
|
||||
runEvalM, runEvalMWithOpts, stdPredef, globals, withState,
|
||||
runEvalM, runEvalMWithOpts, reset, reset1, stdPredef, globals, withState,
|
||||
PredefImpl, Predef(..), ($\),
|
||||
pdCanonicalArgs, pdArity,
|
||||
normalForm, normalFlatForm,
|
||||
eval, apply, value2term, value2termM, bubble, patternMatch, vtableSelect, State(..),
|
||||
newResiduation, getMeta, setMeta, MetaState(..), variants, try,
|
||||
evalError, evalWarn, ppValue, Choice(..), unit, poison, split, split3, split4, mapC, mapCM) where
|
||||
evalError, evalWarn, ppValue, Choice(..), unit, poison, split, split3, split4,
|
||||
mapC, forC, mapCM, forCM) where
|
||||
|
||||
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.CheckM
|
||||
import GF.Data.Operations(Err(..))
|
||||
import GF.Data.Utilities(maybeAt,splitAt',(<||>),anyM)
|
||||
import GF.Data.Utilities(maybeAt,splitAt',(<||>),anyM,secondM,bimapM)
|
||||
import GF.Grammar.Lookup(lookupResDef,lookupOrigInfo)
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Macros
|
||||
@@ -95,21 +96,23 @@ data Value
|
||||
| VCRecType [(Label, Bool, Value)]
|
||||
| VCInts (Maybe Integer) (Maybe Integer)
|
||||
|
||||
third f (a,b,c) = (a, b, f c)
|
||||
|
||||
data Variants
|
||||
= VarFree [Value]
|
||||
| VarOpts Value [(Value, Value)]
|
||||
| VarOpts Value Value [(Value, Value, Value)]
|
||||
|
||||
mapVariants :: (Value -> Value) -> Variants -> Variants
|
||||
mapVariants f (VarFree vs) = VarFree (f <$> vs)
|
||||
mapVariants f (VarOpts n cs) = VarOpts n (second f <$> cs)
|
||||
mapVariants f (VarOpts nty n cs) = VarOpts nty n (third f <$> cs)
|
||||
|
||||
mapVariantsC :: (Choice -> Value -> Value) -> Choice -> Variants -> Variants
|
||||
mapVariantsC f c (VarFree vs) = VarFree (mapC f c vs)
|
||||
mapVariantsC f c (VarOpts n cs) = VarOpts n (mapC (second . f) c cs)
|
||||
mapVariantsC f c (VarOpts nty n cs) = VarOpts nty n (mapC (third . f) c cs)
|
||||
|
||||
unvariants :: Variants -> [Value]
|
||||
unvariants (VarFree vs) = vs
|
||||
unvariants (VarOpts n cs) = snd <$> cs
|
||||
unvariants (VarOpts nty n cs) = cs <&> \(_,_,v) -> v
|
||||
|
||||
isCanonicalForm :: Bool -> Value -> Bool
|
||||
isCanonicalForm flat (VClosure {}) = True
|
||||
@@ -141,19 +144,19 @@ data ConstValue a
|
||||
|
||||
data ConstVariants a
|
||||
= ConstFree [ConstValue a]
|
||||
| ConstOpts Value [(Value, ConstValue a)]
|
||||
| ConstOpts Value Value [(Value, Value, ConstValue a)]
|
||||
|
||||
mapConstVs :: (ConstValue a -> ConstValue b) -> ConstVariants a -> ConstVariants b
|
||||
mapConstVs f (ConstFree vs) = ConstFree (f <$> vs)
|
||||
mapConstVs f (ConstOpts n cs) = ConstOpts n (second f <$> cs)
|
||||
mapConstVs f (ConstOpts nty n cs) = ConstOpts nty n (third f <$> cs)
|
||||
|
||||
mapConstVsC :: (Choice -> ConstValue a -> ConstValue b) -> Choice -> ConstVariants a -> ConstVariants b
|
||||
mapConstVsC f c (ConstFree vs) = ConstFree (mapC f c vs)
|
||||
mapConstVsC f c (ConstOpts n cs) = ConstOpts n (mapC (second . f) c cs)
|
||||
mapConstVsC f c (ConstOpts nty n cs) = ConstOpts nty n (mapC (third . f) c cs)
|
||||
|
||||
unconstVs :: ConstVariants a -> [ConstValue a]
|
||||
unconstVs (ConstFree vs) = vs
|
||||
unconstVs (ConstOpts n cs) = snd <$> cs
|
||||
unconstVs (ConstOpts nty n cs) = cs <&> \(_,_,v) -> v
|
||||
|
||||
instance Functor ConstValue where
|
||||
fmap f (Const c) = Const (f c)
|
||||
@@ -177,11 +180,11 @@ instance Applicative ConstValue where
|
||||
|
||||
variants2consts :: (Value -> ConstValue a) -> Variants -> ConstVariants a
|
||||
variants2consts f (VarFree vs) = ConstFree (f <$> vs)
|
||||
variants2consts f (VarOpts n os) = ConstOpts n (second f <$> os)
|
||||
variants2consts f (VarOpts nty n os) = ConstOpts nty n (third f <$> os)
|
||||
|
||||
consts2variants :: (ConstValue a -> Value) -> ConstVariants a -> Variants
|
||||
consts2variants f (ConstFree vs) = VarFree (f <$> vs)
|
||||
consts2variants f (ConstOpts n os) = VarOpts n (second f <$> os)
|
||||
consts2variants f (ConstOpts nty n os) = VarOpts nty n (third f <$> os)
|
||||
|
||||
normalForm :: Globals -> Term -> Check Term
|
||||
normalForm g t = value2term g [] (bubble (eval g [] unit t []))
|
||||
@@ -335,13 +338,16 @@ eval g env c (Markup tag as ts) [] =
|
||||
in (VMarkup tag vas vs)
|
||||
eval g env c (Reset ctl mb_ct t qid) [] = VReset ctl (fmap (\t -> eval g env c t []) mb_ct) (eval g env c t []) qid
|
||||
eval g env c (TSymCat d r rs) []= VSymCat d r [(i,(fromJust (lookup pv env),ty)) | (i,(pv,ty)) <- rs]
|
||||
eval g env c t@(Opts n cs) vs = if null cs
|
||||
eval g env c t@(Opts (nty,n) cs) vs = if null cs
|
||||
then VError ("No options in expression:" $$ ppTerm Unqualified 0 t)
|
||||
else let (c1,c2,c3) = split3 c
|
||||
vn = eval g env c1 n []
|
||||
vcs = mapC evalOpt c cs
|
||||
in VFV c3 (VarOpts vn vcs)
|
||||
where evalOpt c' (l,t) = let (c1,c2) = split c' in (eval g env c1 l [], eval g env c2 t vs)
|
||||
(c1ty,c1t) = split c1
|
||||
vnty = eval g env c1ty (fromJust nty) []
|
||||
vn = eval g env c1t n []
|
||||
vcs = mapC evalOpt c2 cs
|
||||
in VFV c3 (VarOpts vnty vn vcs)
|
||||
where evalOpt c' ((lty,l),t) = let (c1,c2,c3) = split3 c'
|
||||
in (eval g env c1 (fromJust lty) [], eval g env c2 l [], eval g env c3 t vs)
|
||||
eval g env c t vs = VError ("Cannot reduce term" <+> pp t)
|
||||
|
||||
evalPredef :: Globals -> Choice -> Ident -> [Value] -> Value
|
||||
@@ -388,134 +394,81 @@ apply g (VS v1 v2 vs') vs = VS v1 v2 (vs'++vs)
|
||||
apply g (VClosure env s (Abs b x t)) (v:vs) = eval g ((x,v):env) s t vs
|
||||
apply g v [] = v
|
||||
|
||||
data BubbleVariants
|
||||
= BubbleFree Int
|
||||
| BubbleOpts Value [Value]
|
||||
data Bubbled a
|
||||
= BLeaf a
|
||||
| BFree Choice [Bubbled a]
|
||||
| BOpts Choice Value Value [(Value, Value, Bubbled a)]
|
||||
|
||||
bubble v = snd (bubble v)
|
||||
instance Functor Bubbled where
|
||||
fmap = liftM
|
||||
|
||||
instance Applicative Bubbled where
|
||||
pure = BLeaf
|
||||
(<*>) = ap
|
||||
|
||||
instance Monad Bubbled where
|
||||
BLeaf a >>= k = k a
|
||||
BFree c as >>= k = BFree c ((>>= k) <$> as)
|
||||
BOpts c nty n as >>= k = BOpts c nty n (third (>>= k) <$> as)
|
||||
|
||||
unbubble :: Bubbled Value -> Value
|
||||
unbubble (BLeaf v) = v
|
||||
unbubble (BFree c vs) = VFV c (VarFree (unbubble <$> vs))
|
||||
unbubble (BOpts c nty n cs) = VFV c (VarOpts nty n (third unbubble <$> cs))
|
||||
|
||||
bubble v = unbubble (bubble' v)
|
||||
where
|
||||
bubble (VApp c f vs) = liftL (VApp c f) vs
|
||||
bubble (VMeta metaid vs) = liftL (VMeta metaid) vs
|
||||
bubble (VSusp metaid k vs) = liftL (VSusp metaid k) vs
|
||||
bubble (VGen i vs) = liftL (VGen i) vs
|
||||
bubble (VClosure env c t) = liftL' (\env -> VClosure env c t) env
|
||||
bubble (VProd bt x v1 v2) = lift2 (VProd bt x) v1 v2
|
||||
bubble (VRecType as) = liftL' VRecType as
|
||||
bubble (VR as) = liftL' VR as
|
||||
bubble (VP v l vs) = lift1L (\v vs -> VP v l vs) v vs
|
||||
bubble (VExtR v1 v2) = lift2 VExtR v1 v2
|
||||
bubble (VTable v1 v2) = lift2 VTable v1 v2
|
||||
bubble (VT v env c cs) = lift1L' (\v env -> VT v env c cs) v env
|
||||
bubble (VV v vs) = lift1L VV v vs
|
||||
bubble (VS v1 v2 vs) = lift2L VS v1 v2 vs
|
||||
bubble v@(VSort _) = lift0 v
|
||||
bubble v@(VInt _) = lift0 v
|
||||
bubble v@(VFlt _) = lift0 v
|
||||
bubble v@(VStr _) = lift0 v
|
||||
bubble v@VEmpty = lift0 v
|
||||
bubble (VC v1 v2) = lift2 VC v1 v2
|
||||
bubble (VGlue v1 v2) = lift2 VGlue v1 v2
|
||||
bubble v@(VPatt _ _ _) = lift0 v
|
||||
bubble (VPattType v) = lift1 VPattType v
|
||||
bubble v@(VFV c (VarFree vs))
|
||||
| null vs = (Map.empty, v)
|
||||
| otherwise = let (union,vs') = mapAccumL descend Map.empty vs
|
||||
in (Map.insert c (BubbleFree (length vs),1) union, addVariants (VFV c (VarFree vs')) union)
|
||||
bubble v@(VFV c (VarOpts n os))
|
||||
| null os = (Map.empty, v)
|
||||
| otherwise = let (union,os') = mapAccumL (\acc (k,v) -> second (k,) $ descend acc v) Map.empty os
|
||||
in (Map.insert c (BubbleOpts n (fst <$> os),1) union, addVariants (VFV c (VarOpts n os')) union)
|
||||
bubble (VAlts v vs) = lift1L2 VAlts v vs
|
||||
bubble (VStrs vs) = liftL VStrs vs
|
||||
bubble (VMarkup tag attrs vs) =
|
||||
let (union1,attrs') = mapAccumL descend' Map.empty attrs
|
||||
(union2,vs') = mapAccumL descend union1 vs
|
||||
in (union2, VMarkup tag attrs' vs')
|
||||
bubble (VReset ctl mb_cv v id) = lift1 (\v -> VReset ctl mb_cv v id) v
|
||||
bubble (VSymCat d i0 vs) =
|
||||
let (union,vs') = mapAccumL descendC Map.empty vs
|
||||
in (union, addVariants (VSymCat d i0 vs') union)
|
||||
bubble v@(VError _) = lift0 v
|
||||
bubble v@(VCRecType lbls) =
|
||||
let (union,lbls') = mapAccumL descendR Map.empty lbls
|
||||
in (union, addVariants (VCRecType lbls') union)
|
||||
bubble v@(VCInts _ _) = lift0 v
|
||||
bubble' :: Value -> Bubbled Value
|
||||
bubble' (VApp c f vs) = liftL (VApp c f) vs
|
||||
bubble' (VMeta metaid vs) = liftL (VMeta metaid) vs
|
||||
bubble' (VSusp metaid k vs) = liftL (VSusp metaid k) vs
|
||||
bubble' (VGen i vs) = liftL (VGen i) vs
|
||||
bubble' (VClosure env c t) = liftL' (\env -> VClosure env c t) env
|
||||
bubble' (VProd bt x v1 v2) = lift2 (VProd bt x) v1 v2
|
||||
bubble' (VRecType as) = liftL' VRecType as
|
||||
bubble' (VR as) = liftL' VR as
|
||||
bubble' (VP v l vs) = lift1L (\v vs -> VP v l vs) v vs
|
||||
bubble' (VExtR v1 v2) = lift2 VExtR v1 v2
|
||||
bubble' (VTable v1 v2) = lift2 VTable v1 v2
|
||||
bubble' (VT v env c cs) = lift1L' (\v env -> VT v env c cs) v env
|
||||
bubble' (VV v vs) = lift1L VV v vs
|
||||
bubble' (VS v1 v2 vs) = lift2L VS v1 v2 vs
|
||||
bubble' v@(VSort _) = lift0 v
|
||||
bubble' v@(VInt _) = lift0 v
|
||||
bubble' v@(VFlt _) = lift0 v
|
||||
bubble' v@(VStr _) = lift0 v
|
||||
bubble' v@VEmpty = lift0 v
|
||||
bubble' (VC v1 v2) = lift2 VC v1 v2
|
||||
bubble' (VGlue v1 v2) = lift2 VGlue v1 v2
|
||||
bubble' v@(VPatt _ _ _) = lift0 v
|
||||
bubble' (VPattType v) = lift1 VPattType v
|
||||
bubble' (VFV c (VarFree vs)) = BFree c (bubble' <$> vs)
|
||||
bubble' (VFV c (VarOpts nty n os)) = BOpts c nty n (third bubble' <$> os)
|
||||
bubble' (VAlts v vs) = lift1L2 VAlts v vs
|
||||
bubble' (VStrs vs) = liftL VStrs vs
|
||||
bubble' (VMarkup tag attrs vs) = do
|
||||
attrs' <- mapM (secondM bubble') attrs
|
||||
vs' <- mapM bubble' vs
|
||||
return $ VMarkup tag attrs' vs'
|
||||
bubble' (VReset ctl mb_cv v id) = lift1 (\v -> VReset ctl mb_cv v id) v
|
||||
bubble' (VSymCat d i0 vs) = do
|
||||
vs' <- forM vs $ \(i,(v,ty)) -> (i,) . (,ty) <$> bubble' v
|
||||
return $ VSymCat d i0 vs'
|
||||
bubble' v@(VError _) = lift0 v
|
||||
bubble' v@(VCRecType lbls) = do
|
||||
lbls' <- forM lbls $ \(l,b,v) -> (l,b,) <$> bubble' v
|
||||
return $ VCRecType lbls'
|
||||
bubble' v@(VCInts _ _) = lift0 v
|
||||
|
||||
lift0 v = (Map.empty, v)
|
||||
|
||||
lift1 f v =
|
||||
let (union,v') = bubble v
|
||||
in (union,f v')
|
||||
|
||||
liftL f vs =
|
||||
let (union,vs') = mapAccumL descend Map.empty vs
|
||||
in (union, addVariants (f vs') union)
|
||||
|
||||
liftL' f vs =
|
||||
let (union,vs') = mapAccumL descend' Map.empty vs
|
||||
in (union, addVariants (f vs') union)
|
||||
|
||||
lift1L f v vs =
|
||||
let (choices,v') = bubble v
|
||||
(union, vs') = mapAccumL descend (unitfy choices) vs
|
||||
in (union, addVariants (f v' vs') union)
|
||||
|
||||
lift1L' f v vs =
|
||||
let (choices,v') = bubble v
|
||||
(union, vs') = mapAccumL descend' (unitfy choices) vs
|
||||
in (union, addVariants (f v' vs') union)
|
||||
|
||||
lift1L2 f v vs =
|
||||
let (choices,v') = bubble v
|
||||
(union, vs') = mapAccumL descend2 (unitfy choices) vs
|
||||
in (union, addVariants (f v' vs') union)
|
||||
|
||||
lift2L f v1 v2 vs =
|
||||
let (choices1,v1') = bubble v1
|
||||
(choices2,v2') = bubble v2
|
||||
union = mergeChoices2 choices1 choices2
|
||||
(union', vs') = mapAccumL descend union vs
|
||||
in (union', addVariants (f v1' v2' vs') union')
|
||||
|
||||
lift2 f v1 v2 =
|
||||
let (choices1,v1') = bubble v1
|
||||
(choices2,v2') = bubble v2
|
||||
union = mergeChoices2 choices1 choices2
|
||||
in (union, addVariants (f v1' v2') union)
|
||||
|
||||
descend union v =
|
||||
let (choices,v') = bubble v
|
||||
in (mergeChoices1 union choices,v')
|
||||
|
||||
descend' :: Map.Map Choice (BubbleVariants,Int) -> (a,Value) -> (Map.Map Choice (BubbleVariants,Int),(a,Value))
|
||||
descend' union (x,v) =
|
||||
let (choices,v') = bubble v
|
||||
in (mergeChoices1 union choices,(x,v'))
|
||||
|
||||
descend2 union (v1,v2) =
|
||||
let (choices1,v1') = bubble v1
|
||||
(choices2,v2') = bubble v2
|
||||
in (mergeChoices1 (mergeChoices1 union choices1) choices2,(v1',v2'))
|
||||
|
||||
descendC union (i,(v,ty)) =
|
||||
let (choices,v') = bubble v
|
||||
in (mergeChoices1 union choices,(i,(v',ty)))
|
||||
|
||||
descendR union (l,b,v) =
|
||||
let (choices,v') = bubble v
|
||||
in (mergeChoices1 union choices,(l,b,v'))
|
||||
|
||||
addVariants v = Map.foldrWithKey addVariant v
|
||||
where
|
||||
addVariant c (bvs,cnt) v
|
||||
| cnt > 1 = VFV c $ case bvs of
|
||||
BubbleFree k -> VarFree (replicate k v)
|
||||
BubbleOpts n os -> VarOpts n ((,v) <$> os)
|
||||
| otherwise = v
|
||||
|
||||
unitfy = fmap (\(n,_) -> (n,1))
|
||||
mergeChoices1 = Map.mergeWithKey (\c (n,cnt) _ -> Just (n,cnt+1)) id unitfy
|
||||
mergeChoices2 = Map.mergeWithKey (\c (n,cnt) _ -> Just (n,2)) unitfy unitfy
|
||||
lift0 = BLeaf
|
||||
lift1 f v = f <$> bubble' v
|
||||
liftL f vs = f <$> mapM bubble' vs
|
||||
liftL' f xvs = f <$> mapM (secondM bubble') xvs
|
||||
lift1L f v vs = liftM2 f (bubble' v) (mapM bubble' vs)
|
||||
lift1L' f v xvs = liftM2 f (bubble' v) (mapM (secondM bubble') xvs)
|
||||
lift1L2 f v uvs = liftM2 f (bubble' v) (mapM (bimapM bubble' bubble') uvs)
|
||||
lift2L f v1 v2 vs = liftM3 f (bubble' v1) (bubble' v2) (mapM bubble' vs)
|
||||
lift2 f v1 v2 = liftM2 f (bubble' v1) (bubble' v2)
|
||||
|
||||
toPBool True = VApp poison (cPredef,cPTrue) []
|
||||
toPBool False = VApp poison (cPredef,cPFalse) []
|
||||
@@ -679,8 +632,9 @@ data MetaState
|
||||
data OptionInfo
|
||||
= OptionInfo
|
||||
{ optChoice :: Choice
|
||||
, optLabelType :: Value
|
||||
, optLabel :: Value
|
||||
, optChoices :: [Value]
|
||||
, optChoices :: [(Value, Value)]
|
||||
}
|
||||
type ChoiceMap = Map.Map Choice Int
|
||||
data State
|
||||
@@ -747,6 +701,12 @@ reset (EvalM f) = EvalM $ \g k state r ws ->
|
||||
Fail msg ws -> Fail msg ws
|
||||
Success xs ws -> k (reverse xs) state r ws
|
||||
|
||||
reset1 :: EvalM a -> EvalM (Maybe a)
|
||||
reset1 (EvalM f) = EvalM $ \g k state r ws ->
|
||||
case f g (\x' state x ws -> Success (x <|> Just x') ws) state Nothing ws of
|
||||
Fail msg ws -> Fail msg ws
|
||||
Success x ws -> k x state r ws
|
||||
|
||||
globals :: EvalM Globals
|
||||
globals = EvalM (\g k -> k g)
|
||||
|
||||
@@ -916,12 +876,12 @@ value2termM True xs (VFV i (VarFree vs)) = do
|
||||
v <- variants i vs
|
||||
value2termM True xs v
|
||||
value2termM False xs (VFV i (VarFree vs)) = variants' i (value2termM False xs) vs
|
||||
value2termM flat xs (VFV i (VarOpts n os)) =
|
||||
value2termM flat xs (VFV i (VarOpts nty n os)) =
|
||||
EvalM $ \g k (State choices metas opts) r msgs ->
|
||||
let j = fromMaybe 0 (Map.lookup i choices)
|
||||
in case os `maybeAt` j of
|
||||
Just (l,t) -> case value2termM flat xs t of
|
||||
EvalM f -> let oi = OptionInfo i n (fst <$> os)
|
||||
Just (lty,l,t) -> case value2termM flat xs t of
|
||||
EvalM f -> let oi = OptionInfo i nty n (os <&> \(lty,l,_) -> (lty,l))
|
||||
in f g k (State choices metas (oi:opts)) r msgs
|
||||
Nothing -> Fail ("Index" <+> j <+> "out of bounds for option:" $$ ppValue Unqualified 0 n) msgs
|
||||
value2termM flat xs (VPatt min max p) = return (EPatt min max p)
|
||||
@@ -1029,7 +989,9 @@ ppValue q d (VC v1 v2) = prec d 1 (hang (ppValue q 2 v1) 2 ("++" <+> ppValue q 1
|
||||
ppValue q d (VGlue v1 v2) = prec d 2 (ppValue q 3 v1 <+> '+' <+> ppValue q 2 v2)
|
||||
ppValue q d (VPatt _ _ _) = pp "VPatt"
|
||||
ppValue q d (VPattType _) = pp "VPattType"
|
||||
ppValue q d (VFV i vs) = prec d 4 ("variants" <+> pp i <+> braces (fsep (punctuate ';' (map (ppValue q 0) (unvariants vs)))))
|
||||
ppValue q d (VFV i (VarFree vs)) = prec d 4 ("variants" <+> pp i <+> braces (fsep (punctuate ';' (map (ppValue q 0) vs))))
|
||||
ppValue q d (VFV i (VarOpts _ n os)) = prec d 4 ("option" <+> ppValue q 0 n <+> "of" <+> pp i <+> braces (fsep (punctuate ';'
|
||||
(map (\(_,l,v) -> parens (ppValue q 0 l) <+> "=>" <+> ppValue q 0 v) os))))
|
||||
ppValue q d (VAlts e xs) = prec d 4 ("pre" <+> braces (ppValue q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
|
||||
ppValue q d (VStrs _) = pp "VStrs"
|
||||
ppValue q d (VMarkup _ _ _) = pp "VMarkup"
|
||||
@@ -1138,6 +1100,9 @@ mapC f c (x:xs) =
|
||||
let (!c1,!c2) = split c
|
||||
in f c1 x : mapC f c2 xs
|
||||
|
||||
forC :: Choice -> [a] -> (Choice -> a -> b) -> [b]
|
||||
forC c xs f = mapC f c xs
|
||||
|
||||
mapCM :: Monad m => (Choice -> a -> m b) -> Choice -> [a] -> m [b]
|
||||
mapCM f c [] = return []
|
||||
mapCM f c [x] = do y <- f c x
|
||||
@@ -1147,3 +1112,6 @@ mapCM f c (x:xs) = do
|
||||
y <- f c1 x
|
||||
ys <- mapCM f c2 xs
|
||||
return (y:ys)
|
||||
|
||||
forCM :: Monad m => Choice -> [a] -> (Choice -> a -> m b) -> m [b]
|
||||
forCM c xs f = mapCM f c xs
|
||||
|
||||
@@ -23,6 +23,7 @@ import GF.Compile.Compute.Concrete2
|
||||
, ChoiceMap
|
||||
, Globals(Gl)
|
||||
, OptionInfo(..)
|
||||
, bubble
|
||||
, stdPredef
|
||||
, unit
|
||||
, eval
|
||||
@@ -57,7 +58,6 @@ import GF.Infra.Ident (moduleNameS)
|
||||
import GF.Infra.Option (noOptions)
|
||||
import GF.Infra.UseIO (justModuleName)
|
||||
import GF.Text.Pretty (render)
|
||||
import Debug.Trace
|
||||
|
||||
data ReplOpts = ReplOpts
|
||||
{ lang :: Lang
|
||||
@@ -282,11 +282,11 @@ runRepl' opts@ReplOpts { lang, evalToFlat } gl@(Gl g _) = do
|
||||
outputStrLn $ show i ++ (if null opts then ". " else "*. ") ++ render (ppTerm Unqualified 0 r)
|
||||
|
||||
outputOptions ois os =
|
||||
forM_ ois $ \(OptionInfo c n ls) -> do
|
||||
forM_ ois $ \(OptionInfo c _ n ls) -> do
|
||||
outputStrLn ""
|
||||
outputStrLn $ show (unchoice c) ++ ") " ++ render (ppValue Unqualified 0 n)
|
||||
let sel = fromMaybe 0 (Map.lookup c os) + 1
|
||||
forM_ (zip [1..] ls) $ \(i, l) ->
|
||||
forM_ (zip [1..] ls) $ \(i, (_,l)) ->
|
||||
outputStrLn $ (if i == sel then "->" else " ") ++ show i ++ ". " ++ render (ppValue Unqualified 0 l)
|
||||
|
||||
runRepl :: ReplOpts -> IO ()
|
||||
|
||||
@@ -407,12 +407,17 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
|
||||
VApp c qid [] -> return (Reset ctl mb_ct t qid, ty)
|
||||
_ -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty)
|
||||
| otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
|
||||
tcRho scope s (Opts n cs) mb_ty = do
|
||||
tcRho scope s (Opts (nty,n) cs) mb_ty = do
|
||||
gl <- globals
|
||||
let (s1,s2,s3) = split3 s
|
||||
(n,_) <- tcRho scope s1 n Nothing
|
||||
(ls,_) <- tcUnifying scope s2 (fst <$> cs) Nothing
|
||||
(n,nty) <- tcRho scope s1 n (nty <&> \ty -> eval gl [] poison ty [])
|
||||
nty <- value2termM True [] nty
|
||||
ls <- forCM s2 cs $ \s' ((lty,l),_) -> do
|
||||
(l,lty) <- tcRho scope s' l (lty <&> \ty -> eval gl [] poison ty [])
|
||||
lty <- value2termM True [] lty
|
||||
return (Just lty, l)
|
||||
(ts,ty) <- tcUnifying scope s3 (snd <$> cs) mb_ty
|
||||
return (Opts n (zip ls ts), ty)
|
||||
return (Opts (Just nty, n) (zip ls ts), ty)
|
||||
tcRho scope s t _ = unimplemented ("tcRho "++show t)
|
||||
|
||||
evalCodomain :: Scope -> Ident -> Value -> EvalM Value
|
||||
@@ -1179,9 +1184,9 @@ quantify scope t tvs ty = do
|
||||
check m n xs (VFV c (VarFree vs)) = do
|
||||
(xs,vs) <- mapAccumM (check m n) xs vs
|
||||
return (xs,VFV c (VarFree vs))
|
||||
check m n xs (VFV c (VarOpts name os)) = do
|
||||
(xs,os) <- mapAccumM (\acc (l,v) -> second (l,) <$> check m n acc v) xs os
|
||||
return (xs,VFV c (VarOpts name os))
|
||||
check m n xs (VFV c (VarOpts nty name os)) = do
|
||||
(xs,os) <- mapAccumM (\acc (lty,l,v) -> second (lty,l,) <$> check m n acc v) xs os
|
||||
return (xs,VFV c (VarOpts nty name os))
|
||||
check m n xs (VAlts v vs) = do
|
||||
(xs,v) <- check m n xs v
|
||||
(xs,vs) <- mapAccumM (\xs (v1,v2) -> do (xs,v1) <- check m n xs v1
|
||||
|
||||
@@ -11,13 +11,13 @@
|
||||
-- Basic functions not in the standard libraries
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
module GF.Data.Utilities(module GF.Data.Utilities) where
|
||||
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Maybe
|
||||
import Data.List
|
||||
import Control.Monad (MonadPlus(..),foldM,liftM,when)
|
||||
import Control.Monad (MonadPlus(..),foldM,liftM,liftM2,when)
|
||||
import Control.Applicative(liftA2)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
@@ -128,7 +128,7 @@ compareBy f = both f compare
|
||||
both :: (a -> b) -> (b -> b -> c) -> a -> a -> c
|
||||
both f g x y = g (f x) (f y)
|
||||
|
||||
-- * functions on pairs
|
||||
-- * functions on tuples
|
||||
|
||||
apFst :: (a -> a') -> (a, b) -> (a', b)
|
||||
apFst f (a, b) = (f a, b)
|
||||
@@ -174,6 +174,18 @@ allM p = foldM (\b x -> if b then p x else return False) True
|
||||
anyM :: (Foldable f, Monad m) => (a -> m Bool) -> f a -> m Bool
|
||||
anyM p = foldM (\b x -> if b then return True else p x) False
|
||||
|
||||
-- | Lifts a monadic action to pairs in the first element.
|
||||
firstM :: Monad m => (a -> m a') -> (a, b) -> m (a', b)
|
||||
firstM f (a, b) = (,b) <$> f a
|
||||
|
||||
-- | Lifts a monadic action to pairs in the second element.
|
||||
secondM :: Monad m => (b -> m b') -> (a, b) -> m (a, b')
|
||||
secondM f (a, b) = (a,) <$> f b
|
||||
|
||||
-- | Lifts a pair of monadic actions to an action on pairs, sequencing left-to-right.
|
||||
bimapM :: Monad m => (a -> m a') -> (b -> m b') -> (a, b) -> m (a', b')
|
||||
bimapM f g (a, b) = liftM2 (,) (f a) (g b)
|
||||
|
||||
-- * functions on Maybes
|
||||
|
||||
-- | Returns the argument on the right, or a default value on the left.
|
||||
|
||||
@@ -344,6 +344,7 @@ data Info =
|
||||
deriving Show
|
||||
|
||||
type Type = Term
|
||||
type MTyTerm = (Maybe Term, Term)
|
||||
type Cat = QIdent
|
||||
type Fun = QIdent
|
||||
|
||||
@@ -373,7 +374,7 @@ data Term =
|
||||
| P Term Label -- ^ projection: @r.p@
|
||||
| ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms)
|
||||
|
||||
| Opts Term [Option] -- ^ options: @options s in { e => x ; ... }@
|
||||
| Opts MTyTerm [Option] -- ^ options: @options s in { e => x ; ... }@
|
||||
|
||||
| Table Term Term -- ^ table type: @P => A@
|
||||
| T TInfo [Case] -- ^ table: @table {p => c ; ...}@
|
||||
@@ -466,7 +467,7 @@ type Equation = ([Patt],Term)
|
||||
|
||||
type Labelling = (Label, Type)
|
||||
type Assign = (Label, (Maybe Type, Term))
|
||||
type Option = (Term, Term)
|
||||
type Option = (MTyTerm, Term)
|
||||
type Case = (Patt, Term)
|
||||
--type Cases = ([Patt], Term)
|
||||
type LocalDef = (Ident, (Maybe Type, Term))
|
||||
|
||||
@@ -452,7 +452,7 @@ Exp4 :: { Term }
|
||||
Exp4
|
||||
: Exp4 Exp5 { App $1 $2 }
|
||||
| Exp4 '{' Exp '}' { App $1 (ImplArg $3) }
|
||||
| 'option' Exp 'of' '{' ListOpt '}' { Opts $2 $5 }
|
||||
| 'option' Exp 'of' '{' ListOpt '}' { Opts (Nothing, $2) $5 }
|
||||
| 'case' Exp 'of' '{' ListCase '}' { let annot = case $2 of
|
||||
Typed _ t -> TTyped t
|
||||
_ -> TRaw
|
||||
@@ -611,7 +611,7 @@ ListPattTupleComp
|
||||
|
||||
Opt :: { Option }
|
||||
Opt
|
||||
: '(' Exp ')' '=>' Exp { ($2,$5) }
|
||||
: '(' Exp ')' '=>' Exp { ((Nothing,$2),$5) }
|
||||
|
||||
ListOpt :: { [Option] }
|
||||
ListOpt
|
||||
|
||||
@@ -219,6 +219,8 @@ ppTerm q d (S x y) = case x of
|
||||
ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
|
||||
ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
|
||||
ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
|
||||
ppTerm q d (Opts (_,n) cs) = prec d 4 ("option" <+> ppTerm q 0 n <+> "of" <+> braces (fsep (punctuate ';'
|
||||
(map (\((_,l),t) -> parens (ppTerm q 0 l) <+> "=>" <+> ppTerm q 0 t) cs))))
|
||||
ppTerm q d (FV es) = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
|
||||
ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
|
||||
ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
|
||||
|
||||
Reference in New Issue
Block a user