GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-26 03:08:55 -06:00
Code Issues Packages Projects Releases Wiki Activity

Type annotations for option labels + new bubble impl

Browse Source
This commit is contained in:
Eve
2025-04-22 01:20:48 +02:00
parent 6429ed7148
commit 9c422c8224
7 changed files with 170 additions and 182 deletions
Download Patch File Download Diff File Expand all files Collapse all files

264
src/compiler/api/GF/Compile/Compute/Concrete2.hs
View File

@@ -5,19 +5,20 @@ module GF.Compile.Compute.Concrete2
ConstValue(..), ConstVariants(..), Globals(..), PredefTable, EvalM, ConstValue(..), ConstVariants(..), Globals(..), PredefTable, EvalM,
mapVariants, mapVariantsC, unvariants, variants2consts, mapVariants, mapVariantsC, unvariants, variants2consts,
mapConstVs, mapConstVsC, unconstVs, consts2variants, mapConstVs, mapConstVsC, unconstVs, consts2variants,
runEvalM, runEvalMWithOpts, stdPredef, globals, withState, runEvalM, runEvalMWithOpts, reset, reset1, stdPredef, globals, withState,
PredefImpl, Predef(..), ($\), PredefImpl, Predef(..), ($\),
pdCanonicalArgs, pdArity, pdCanonicalArgs, pdArity,
normalForm, normalFlatForm, normalForm, normalFlatForm,
eval, apply, value2term, value2termM, bubble, patternMatch, vtableSelect, State(..), eval, apply, value2term, value2termM, bubble, patternMatch, vtableSelect, State(..),
newResiduation, getMeta, setMeta, MetaState(..), variants, try, 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 Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import GF.Infra.Ident import GF.Infra.Ident
import GF.Infra.CheckM import GF.Infra.CheckM
import GF.Data.Operations(Err(..)) 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.Lookup(lookupResDef,lookupOrigInfo)
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Grammar.Macros import GF.Grammar.Macros
@@ -95,21 +96,23 @@ data Value
| VCRecType [(Label, Bool, Value)] | VCRecType [(Label, Bool, Value)]
| VCInts (Maybe Integer) (Maybe Integer) | VCInts (Maybe Integer) (Maybe Integer)
third f (a,b,c) = (a, b, f c)
data Variants data Variants
= VarFree [Value] = VarFree [Value]
| VarOpts Value [(Value, Value)] | VarOpts Value Value [(Value, Value, Value)]
mapVariants :: (Value -> Value) -> Variants -> Variants mapVariants :: (Value -> Value) -> Variants -> Variants
mapVariants f (VarFree vs) = VarFree (f <$> vs) 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 :: (Choice -> Value -> Value) -> Choice -> Variants -> Variants
mapVariantsC f c (VarFree vs) = VarFree (mapC f c vs) 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 :: Variants -> [Value]
unvariants (VarFree vs) = vs unvariants (VarFree vs) = vs
unvariants (VarOpts n cs) = snd <$> cs unvariants (VarOpts nty n cs) = cs <&> \(_,_,v) -> v
isCanonicalForm :: Bool -> Value -> Bool isCanonicalForm :: Bool -> Value -> Bool
isCanonicalForm flat (VClosure {}) = True isCanonicalForm flat (VClosure {}) = True
@@ -141,19 +144,19 @@ data ConstValue a
data ConstVariants a data ConstVariants a
= ConstFree [ConstValue 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 :: (ConstValue a -> ConstValue b) -> ConstVariants a -> ConstVariants b
mapConstVs f (ConstFree vs) = ConstFree (f <$> vs) 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 :: (Choice -> ConstValue a -> ConstValue b) -> Choice -> ConstVariants a -> ConstVariants b
mapConstVsC f c (ConstFree vs) = ConstFree (mapC f c vs) 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 :: ConstVariants a -> [ConstValue a]
unconstVs (ConstFree vs) = vs unconstVs (ConstFree vs) = vs
unconstVs (ConstOpts n cs) = snd <$> cs unconstVs (ConstOpts nty n cs) = cs <&> \(_,_,v) -> v
instance Functor ConstValue where instance Functor ConstValue where
fmap f (Const c) = Const (f c) fmap f (Const c) = Const (f c)
@@ -177,11 +180,11 @@ instance Applicative ConstValue where
variants2consts :: (Value -> ConstValue a) -> Variants -> ConstVariants a variants2consts :: (Value -> ConstValue a) -> Variants -> ConstVariants a
variants2consts f (VarFree vs) = ConstFree (f <$> vs) 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 :: (ConstValue a -> Value) -> ConstVariants a -> Variants
consts2variants f (ConstFree vs) = VarFree (f <$> vs) 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 :: Globals -> Term -> Check Term
normalForm g t = value2term g [] (bubble (eval g [] unit t [])) 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) 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 (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 (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) then VError ("No options in expression:" $$ ppTerm Unqualified 0 t)
else let (c1,c2,c3) = split3 c else let (c1,c2,c3) = split3 c
vn = eval g env c1 n [] (c1ty,c1t) = split c1
vcs = mapC evalOpt c cs vnty = eval g env c1ty (fromJust nty) []
in VFV c3 (VarOpts vn vcs) vn = eval g env c1t n []
where evalOpt c' (l,t) = let (c1,c2) = split c' in (eval g env c1 l [], eval g env c2 t vs) 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) eval g env c t vs = VError ("Cannot reduce term" <+> pp t)
evalPredef :: Globals -> Choice -> Ident -> [Value] -> Value 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 (VClosure env s (Abs b x t)) (v:vs) = eval g ((x,v):env) s t vs
apply g v [] = v apply g v [] = v
data BubbleVariants data Bubbled a
= BubbleFree Int = BLeaf a
| BubbleOpts Value [Value] | 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 where
bubble (VApp c f vs) = liftL (VApp c f) vs bubble' :: Value -> Bubbled Value
bubble (VMeta metaid vs) = liftL (VMeta metaid) vs bubble' (VApp c f vs) = liftL (VApp c f) vs
bubble (VSusp metaid k vs) = liftL (VSusp metaid k) vs bubble' (VMeta metaid vs) = liftL (VMeta metaid) vs
bubble (VGen i vs) = liftL (VGen i) vs bubble' (VSusp metaid k vs) = liftL (VSusp metaid k) vs
bubble (VClosure env c t) = liftL' (\env -> VClosure env c t) env bubble' (VGen i vs) = liftL (VGen i) vs
bubble (VProd bt x v1 v2) = lift2 (VProd bt x) v1 v2 bubble' (VClosure env c t) = liftL' (\env -> VClosure env c t) env
bubble (VRecType as) = liftL' VRecType as bubble' (VProd bt x v1 v2) = lift2 (VProd bt x) v1 v2
bubble (VR as) = liftL' VR as bubble' (VRecType as) = liftL' VRecType as
bubble (VP v l vs) = lift1L (\v vs -> VP v l vs) v vs bubble' (VR as) = liftL' VR as
bubble (VExtR v1 v2) = lift2 VExtR v1 v2 bubble' (VP v l vs) = lift1L (\v vs -> VP v l vs) v vs
bubble (VTable v1 v2) = lift2 VTable v1 v2 bubble' (VExtR v1 v2) = lift2 VExtR v1 v2
bubble (VT v env c cs) = lift1L' (\v env -> VT v env c cs) v env bubble' (VTable v1 v2) = lift2 VTable v1 v2
bubble (VV v vs) = lift1L VV v vs bubble' (VT v env c cs) = lift1L' (\v env -> VT v env c cs) v env
bubble (VS v1 v2 vs) = lift2L VS v1 v2 vs bubble' (VV v vs) = lift1L VV v vs
bubble v@(VSort _) = lift0 v bubble' (VS v1 v2 vs) = lift2L VS v1 v2 vs
bubble v@(VInt _) = lift0 v bubble' v@(VSort _) = lift0 v
bubble v@(VFlt _) = lift0 v bubble' v@(VInt _) = lift0 v
bubble v@(VStr _) = lift0 v bubble' v@(VFlt _) = lift0 v
bubble v@VEmpty = lift0 v bubble' v@(VStr _) = lift0 v
bubble (VC v1 v2) = lift2 VC v1 v2 bubble' v@VEmpty = lift0 v
bubble (VGlue v1 v2) = lift2 VGlue v1 v2 bubble' (VC v1 v2) = lift2 VC v1 v2
bubble v@(VPatt _ _ _) = lift0 v bubble' (VGlue v1 v2) = lift2 VGlue v1 v2
bubble (VPattType v) = lift1 VPattType v bubble' v@(VPatt _ _ _) = lift0 v
bubble v@(VFV c (VarFree vs)) bubble' (VPattType v) = lift1 VPattType v
| null vs = (Map.empty, v) bubble' (VFV c (VarFree vs)) = BFree c (bubble' <$> vs)
| otherwise = let (union,vs') = mapAccumL descend Map.empty vs bubble' (VFV c (VarOpts nty n os)) = BOpts c nty n (third bubble' <$> os)
in (Map.insert c (BubbleFree (length vs),1) union, addVariants (VFV c (VarFree vs')) union) bubble' (VAlts v vs) = lift1L2 VAlts v vs
bubble v@(VFV c (VarOpts n os)) bubble' (VStrs vs) = liftL VStrs vs
| null os = (Map.empty, v) bubble' (VMarkup tag attrs vs) = do
| otherwise = let (union,os') = mapAccumL (\acc (k,v) -> second (k,) $ descend acc v) Map.empty os attrs' <- mapM (secondM bubble') attrs
in (Map.insert c (BubbleOpts n (fst <$> os),1) union, addVariants (VFV c (VarOpts n os')) union) vs' <- mapM bubble' vs
bubble (VAlts v vs) = lift1L2 VAlts v vs return $ VMarkup tag attrs' vs'
bubble (VStrs vs) = liftL VStrs vs bubble' (VReset ctl mb_cv v id) = lift1 (\v -> VReset ctl mb_cv v id) v
bubble (VMarkup tag attrs vs) = bubble' (VSymCat d i0 vs) = do
let (union1,attrs') = mapAccumL descend' Map.empty attrs vs' <- forM vs $ \(i,(v,ty)) -> (i,) . (,ty) <$> bubble' v
(union2,vs') = mapAccumL descend union1 vs return $ VSymCat d i0 vs'
in (union2, VMarkup tag attrs' vs') bubble' v@(VError _) = lift0 v
bubble (VReset ctl mb_cv v id) = lift1 (\v -> VReset ctl mb_cv v id) v bubble' v@(VCRecType lbls) = do
bubble (VSymCat d i0 vs) = lbls' <- forM lbls $ \(l,b,v) -> (l,b,) <$> bubble' v
let (union,vs') = mapAccumL descendC Map.empty vs return $ VCRecType lbls'
in (union, addVariants (VSymCat d i0 vs') union) bubble' v@(VCInts _ _) = lift0 v
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
lift0 v = (Map.empty, v) lift0 = BLeaf
lift1 f v = f <$> bubble' v
lift1 f v = liftL f vs = f <$> mapM bubble' vs
let (union,v') = bubble v liftL' f xvs = f <$> mapM (secondM bubble') xvs
in (union,f v') lift1L f v vs = liftM2 f (bubble' v) (mapM bubble' vs)
lift1L' f v xvs = liftM2 f (bubble' v) (mapM (secondM bubble') xvs)
liftL f vs = lift1L2 f v uvs = liftM2 f (bubble' v) (mapM (bimapM bubble' bubble') uvs)
let (union,vs') = mapAccumL descend Map.empty vs lift2L f v1 v2 vs = liftM3 f (bubble' v1) (bubble' v2) (mapM bubble' vs)
in (union, addVariants (f vs') union) lift2 f v1 v2 = liftM2 f (bubble' v1) (bubble' v2)
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
toPBool True = VApp poison (cPredef,cPTrue) [] toPBool True = VApp poison (cPredef,cPTrue) []
toPBool False = VApp poison (cPredef,cPFalse) [] toPBool False = VApp poison (cPredef,cPFalse) []
@@ -679,8 +632,9 @@ data MetaState
data OptionInfo data OptionInfo
= OptionInfo = OptionInfo
{ optChoice :: Choice { optChoice :: Choice
, optLabelType :: Value
, optLabel :: Value , optLabel :: Value
, optChoices :: [Value] , optChoices :: [(Value, Value)]
} }
type ChoiceMap = Map.Map Choice Int type ChoiceMap = Map.Map Choice Int
data State data State
@@ -747,6 +701,12 @@ reset (EvalM f) = EvalM $ \g k state r ws ->
Fail msg ws -> Fail msg ws Fail msg ws -> Fail msg ws
Success xs ws -> k (reverse xs) state r 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 Globals
globals = EvalM (\g k -> k g) globals = EvalM (\g k -> k g)
@@ -916,12 +876,12 @@ value2termM True xs (VFV i (VarFree vs)) = do
v <- variants i vs v <- variants i vs
value2termM True xs v value2termM True xs v
value2termM False xs (VFV i (VarFree vs)) = variants' i (value2termM False xs) vs 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 -> EvalM $ \g k (State choices metas opts) r msgs ->
let j = fromMaybe 0 (Map.lookup i choices) let j = fromMaybe 0 (Map.lookup i choices)
in case os `maybeAt` j of in case os `maybeAt` j of
Just (l,t) -> case value2termM flat xs t of Just (lty,l,t) -> case value2termM flat xs t of
EvalM f -> let oi = OptionInfo i n (fst <$> os) EvalM f -> let oi = OptionInfo i nty n (os <&> \(lty,l,_) -> (lty,l))
in f g k (State choices metas (oi:opts)) r msgs 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 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) 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 (VGlue v1 v2) = prec d 2 (ppValue q 3 v1 <+> '+' <+> ppValue q 2 v2)
ppValue q d (VPatt _ _ _) = pp "VPatt" ppValue q d (VPatt _ _ _) = pp "VPatt"
ppValue q d (VPattType _) = pp "VPattType" 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 (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 (VStrs _) = pp "VStrs"
ppValue q d (VMarkup _ _ _) = pp "VMarkup" ppValue q d (VMarkup _ _ _) = pp "VMarkup"
@@ -1138,6 +1100,9 @@ mapC f c (x:xs) =
let (!c1,!c2) = split c let (!c1,!c2) = split c
in f c1 x : mapC f c2 xs 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 :: Monad m => (Choice -> a -> m b) -> Choice -> [a] -> m [b]
mapCM f c [] = return [] mapCM f c [] = return []
mapCM f c [x] = do y <- f c x mapCM f c [x] = do y <- f c x
@@ -1147,3 +1112,6 @@ mapCM f c (x:xs) = do
y <- f c1 x y <- f c1 x
ys <- mapCM f c2 xs ys <- mapCM f c2 xs
return (y:ys) return (y:ys)
forCM :: Monad m => Choice -> [a] -> (Choice -> a -> m b) -> m [b]
forCM c xs f = mapCM f c xs

6
src/compiler/api/GF/Compile/Repl.hs
View File

@@ -23,6 +23,7 @@ import GF.Compile.Compute.Concrete2
, ChoiceMap , ChoiceMap
, Globals(Gl) , Globals(Gl)
, OptionInfo(..) , OptionInfo(..)
, bubble
, stdPredef , stdPredef
, unit , unit
, eval , eval
@@ -57,7 +58,6 @@ import GF.Infra.Ident (moduleNameS)
import GF.Infra.Option (noOptions) import GF.Infra.Option (noOptions)
import GF.Infra.UseIO (justModuleName) import GF.Infra.UseIO (justModuleName)
import GF.Text.Pretty (render) import GF.Text.Pretty (render)
import Debug.Trace
data ReplOpts = ReplOpts data ReplOpts = ReplOpts
{ lang :: Lang { 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) outputStrLn $ show i ++ (if null opts then ". " else "*. ") ++ render (ppTerm Unqualified 0 r)
outputOptions ois os = outputOptions ois os =
forM_ ois $ \(OptionInfo c n ls) -> do forM_ ois $ \(OptionInfo c _ n ls) -> do
outputStrLn "" outputStrLn ""
outputStrLn $ show (unchoice c) ++ ") " ++ render (ppValue Unqualified 0 n) outputStrLn $ show (unchoice c) ++ ") " ++ render (ppValue Unqualified 0 n)
let sel = fromMaybe 0 (Map.lookup c os) + 1 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) outputStrLn $ (if i == sel then "->" else " ") ++ show i ++ ". " ++ render (ppValue Unqualified 0 l)
runRepl :: ReplOpts -> IO () runRepl :: ReplOpts -> IO ()

19
src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
View File

@@ -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) VApp c qid [] -> return (Reset ctl mb_ct t qid, ty)
_ -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty) _ -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty)
| otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined") | 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 let (s1,s2,s3) = split3 s
(n,_) <- tcRho scope s1 n Nothing (n,nty) <- tcRho scope s1 n (nty <&> \ty -> eval gl [] poison ty [])
(ls,_) <- tcUnifying scope s2 (fst <$> cs) Nothing 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 (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) tcRho scope s t _ = unimplemented ("tcRho "++show t)
evalCodomain :: Scope -> Ident -> Value -> EvalM Value 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 check m n xs (VFV c (VarFree vs)) = do
(xs,vs) <- mapAccumM (check m n) xs vs (xs,vs) <- mapAccumM (check m n) xs vs
return (xs,VFV c (VarFree vs)) return (xs,VFV c (VarFree vs))
check m n xs (VFV c (VarOpts name os)) = do check m n xs (VFV c (VarOpts nty name os)) = do
(xs,os) <- mapAccumM (\acc (l,v) -> second (l,) <$> check m n acc v) xs os (xs,os) <- mapAccumM (\acc (lty,l,v) -> second (lty,l,) <$> check m n acc v) xs os
return (xs,VFV c (VarOpts name os)) return (xs,VFV c (VarOpts nty name os))
check m n xs (VAlts v vs) = do check m n xs (VAlts v vs) = do
(xs,v) <- check m n xs v (xs,v) <- check m n xs v
(xs,vs) <- mapAccumM (\xs (v1,v2) -> do (xs,v1) <- check m n xs v1 (xs,vs) <- mapAccumM (\xs (v1,v2) -> do (xs,v1) <- check m n xs v1

18
src/compiler/api/GF/Data/Utilities.hs
View File

@@ -11,13 +11,13 @@
-- Basic functions not in the standard libraries -- Basic functions not in the standard libraries
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
{-# LANGUAGE TupleSections #-}
module GF.Data.Utilities(module GF.Data.Utilities) where module GF.Data.Utilities(module GF.Data.Utilities) where
import Data.Bifunctor (first) import Data.Bifunctor (first)
import Data.Maybe import Data.Maybe
import Data.List import Data.List
import Control.Monad (MonadPlus(..),foldM,liftM,when) import Control.Monad (MonadPlus(..),foldM,liftM,liftM2,when)
import Control.Applicative(liftA2) import Control.Applicative(liftA2)
import qualified Data.Set as Set 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 :: (a -> b) -> (b -> b -> c) -> a -> a -> c
both f g x y = g (f x) (f y) both f g x y = g (f x) (f y)
-- * functions on pairs -- * functions on tuples
apFst :: (a -> a') -> (a, b) -> (a', b) apFst :: (a -> a') -> (a, b) -> (a', b)
apFst f (a, b) = (f 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 :: (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 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 -- * functions on Maybes
-- | Returns the argument on the right, or a default value on the left. -- | Returns the argument on the right, or a default value on the left.

5
src/compiler/api/GF/Grammar/Grammar.hs
View File

@@ -344,6 +344,7 @@ data Info =
deriving Show deriving Show
type Type = Term type Type = Term
type MTyTerm = (Maybe Term, Term)
type Cat = QIdent type Cat = QIdent
type Fun = QIdent type Fun = QIdent
@@ -373,7 +374,7 @@ data Term =
| P Term Label -- ^ projection: @r.p@ | P Term Label -- ^ projection: @r.p@
| ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms) | 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@ | Table Term Term -- ^ table type: @P => A@
| T TInfo [Case] -- ^ table: @table {p => c ; ...}@ | T TInfo [Case] -- ^ table: @table {p => c ; ...}@
@@ -466,7 +467,7 @@ type Equation = ([Patt],Term)
type Labelling = (Label, Type) type Labelling = (Label, Type)
type Assign = (Label, (Maybe Type, Term)) type Assign = (Label, (Maybe Type, Term))
type Option = (Term, Term) type Option = (MTyTerm, Term)
type Case = (Patt, Term) type Case = (Patt, Term)
--type Cases = ([Patt], Term) --type Cases = ([Patt], Term)
type LocalDef = (Ident, (Maybe Type, Term)) type LocalDef = (Ident, (Maybe Type, Term))

4
src/compiler/api/GF/Grammar/Parser.y
View File

@@ -452,7 +452,7 @@ Exp4 :: { Term }
Exp4 Exp4
: Exp4 Exp5 { App $1 $2 } : Exp4 Exp5 { App $1 $2 }
| Exp4 '{' Exp '}' { App $1 (ImplArg $3) } | 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 | 'case' Exp 'of' '{' ListCase '}' { let annot = case $2 of
Typed _ t -> TTyped t Typed _ t -> TTyped t
_ -> TRaw _ -> TRaw
@@ -611,7 +611,7 @@ ListPattTupleComp
Opt :: { Option } Opt :: { Option }
Opt Opt
: '(' Exp ')' '=>' Exp { ($2,$5) } : '(' Exp ')' '=>' Exp { ((Nothing,$2),$5) }
ListOpt :: { [Option] } ListOpt :: { [Option] }
ListOpt ListOpt

2
src/compiler/api/GF/Grammar/Printer.hs
View File

@@ -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 (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 (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 (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 (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 (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)))) ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))