msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Option evaluation + basic repl support for option manipulation

Browse Source
This commit is contained in:
Eve
2025-03-31 17:52:54 +02:00
parent 8bd0d13dd6
commit b29ec2a47a
4 changed files with 354 additions and 110 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -1,20 +1,22 @@
{-# LANGUAGE RankNTypes, BangPatterns, GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes, BangPatterns, GeneralizedNewtypeDeriving, TupleSections #-}
module GF.Compile.Compute.Concrete2 module GF.Compile.Compute.Concrete2
(Env, Scope, Value(..), Constraint, ConstValue(..), Globals(..), PredefTable, EvalM, (Env, Scope, Value(..), Variants(..), Constraint, OptionInfo(..), ChoiceMap, cleanOptions,
runEvalM, stdPredef, globals, ConstValue(..), ConstVariants(..), Globals(..), PredefTable, EvalM,
mapVariants, unvariants, variants2consts, consts2variants,
runEvalM, runEvalMWithOpts, stdPredef, globals,
PredefImpl, Predef(..), ($\), PredefImpl, Predef(..), ($\),
pdCanonicalArgs, pdArity, pdCanonicalArgs, pdArity,
normalForm, normalFlatForm, normalForm, normalFlatForm,
eval, apply, value2term, value2termM, bubble, patternMatch, vtableSelect, eval, apply, value2term, value2termM, bubble, patternMatch, vtableSelect,
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, mapCM) 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(splitAt',(<||>),anyM) import GF.Data.Utilities(maybeAt,splitAt',(<||>),anyM)
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
@@ -26,6 +28,7 @@ import Control.Monad
import Control.Applicative hiding (Const) import Control.Applicative hiding (Const)
import qualified Control.Applicative as A import qualified Control.Applicative as A
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Bifunctor (second)
import Data.Functor ((<&>)) import Data.Functor ((<&>))
import Data.Maybe (fromMaybe,fromJust) import Data.Maybe (fromMaybe,fromJust)
import Data.List import Data.List
@@ -79,8 +82,7 @@ data Value
| VGlue Value Value | VGlue Value Value
| VPatt Int (Maybe Int) Patt | VPatt Int (Maybe Int) Patt
| VPattType Value | VPattType Value
| VFV Choice [Value] | VFV Choice Variants
| VOpts Choice Value [(Value, Value)]
| VAlts Value [(Value, Value)] | VAlts Value [(Value, Value)]
| VStrs [Value] | VStrs [Value]
| VMarkup Ident [(Ident,Value)] [Value] | VMarkup Ident [(Ident,Value)] [Value]
@@ -92,6 +94,18 @@ data Value
| VCRecType [(Label, Bool, Value)] | VCRecType [(Label, Bool, Value)]
| VCInts (Maybe Integer) (Maybe Integer) | VCInts (Maybe Integer) (Maybe Integer)
data Variants
= VarFree [Value]
| VarOpts 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)
unvariants :: Variants -> [Value]
unvariants (VarFree vs) = vs
unvariants (VarOpts n cs) = snd <$> cs
isCanonicalForm :: Bool -> Value -> Bool isCanonicalForm :: Bool -> Value -> Bool
isCanonicalForm flat (VClosure {}) = True isCanonicalForm flat (VClosure {}) = True
isCanonicalForm flat (VProd b x d cod) = isCanonicalForm flat d && isCanonicalForm flat cod isCanonicalForm flat (VProd b x d cod) = isCanonicalForm flat d && isCanonicalForm flat cod
@@ -105,10 +119,8 @@ isCanonicalForm flat (VInt {}) = True
isCanonicalForm flat (VFlt {}) = True isCanonicalForm flat (VFlt {}) = True
isCanonicalForm flat (VStr {}) = True isCanonicalForm flat (VStr {}) = True
isCanonicalForm flat VEmpty = True isCanonicalForm flat VEmpty = True
isCanonicalForm True (VFV c vs) = False isCanonicalForm True (VFV {}) = False
isCanonicalForm False (VFV c vs) = all (isCanonicalForm False) vs isCanonicalForm False (VFV c vs) = all (isCanonicalForm False) (unvariants vs)
isCanonicalForm True (VOpts c n os) = False
isCanonicalForm False (VOpts c n os) = all (isCanonicalForm False . snd) os
isCanonicalForm flat (VAlts d vs) = all (isCanonicalForm flat . snd) vs isCanonicalForm flat (VAlts d vs) = all (isCanonicalForm flat . snd) vs
isCanonicalForm flat (VStrs vs) = all (isCanonicalForm flat) vs isCanonicalForm flat (VStrs vs) = all (isCanonicalForm flat) vs
isCanonicalForm flat (VMarkup tag as vs) = all (isCanonicalForm flat . snd) as && all (isCanonicalForm flat) vs isCanonicalForm flat (VMarkup tag as vs) = all (isCanonicalForm flat . snd) as && all (isCanonicalForm flat) vs
@@ -118,13 +130,25 @@ isCanonicalForm flat _ = False
data ConstValue a data ConstValue a
= Const a = Const a
| CSusp MetaId (Value -> ConstValue a) | CSusp MetaId (Value -> ConstValue a)
| CFV Choice [ConstValue a] | CFV Choice (ConstVariants a)
| RunTime | RunTime
| NonExist | NonExist
data ConstVariants a
= ConstFree [ConstValue a]
| ConstOpts 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)
unconstVs :: ConstVariants a -> [ConstValue a]
unconstVs (ConstFree vs) = vs
unconstVs (ConstOpts n cs) = snd <$> cs
instance Functor ConstValue where instance Functor ConstValue where
fmap f (Const c) = Const (f c) fmap f (Const c) = Const (f c)
fmap f (CFV i vs) = CFV i (map (fmap f) vs) fmap f (CFV i vs) = CFV i (mapConstVs (fmap f) vs)
fmap f (CSusp i k) = CSusp i (fmap f . k) fmap f (CSusp i k) = CSusp i (fmap f . k)
fmap f RunTime = RunTime fmap f RunTime = RunTime
fmap f NonExist = NonExist fmap f NonExist = NonExist
@@ -133,8 +157,8 @@ instance Applicative ConstValue where
pure = Const pure = Const
(Const f) <*> (Const x) = Const (f x) (Const f) <*> (Const x) = Const (f x)
(CFV s vs) <*> v2 = CFV s [v1 <*> v2 | v1 <- vs] (CFV s vs) <*> v2 = CFV s (mapConstVs (<*> v2) vs)
v1 <*> (CFV s vs) = CFV s [v1 <*> v2 | v2 <- vs] v1 <*> (CFV s vs) = CFV s (mapConstVs (v1 <*>) vs)
(CSusp i k) <*> v2 = CSusp i (\v -> k v <*> v2) (CSusp i k) <*> v2 = CSusp i (\v -> k v <*> v2)
v1 <*> (CSusp i k) = CSusp i (\v -> v1 <*> k v) v1 <*> (CSusp i k) = CSusp i (\v -> v1 <*> k v)
NonExist <*> _ = NonExist NonExist <*> _ = NonExist
@@ -142,6 +166,14 @@ instance Applicative ConstValue where
RunTime <*> _ = RunTime RunTime <*> _ = RunTime
_ <*> RunTime = RunTime _ <*> RunTime = RunTime
variants2consts :: (Value -> ConstValue a) -> Variants -> ConstVariants a
variants2consts f (VarFree vs) = ConstFree (f <$> vs)
variants2consts f (VarOpts n os) = ConstOpts n (second 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)
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 []))
@@ -174,7 +206,7 @@ eval g env s (P t lbl) vs = let project (VR as) = case lookup lbl a
Nothing -> VError ("Missing value for label" <+> pp lbl $$ Nothing -> VError ("Missing value for label" <+> pp lbl $$
"in" <+> pp (P t lbl)) "in" <+> pp (P t lbl))
Just v -> apply g v vs Just v -> apply g v vs
project (VFV s fvs) = VFV s (map project fvs) project (VFV s fvs) = VFV s (mapVariants project fvs)
project (VMeta i vs) = VSusp i (\v -> project (apply g v vs)) [] project (VMeta i vs) = VSusp i (\v -> project (apply g v vs)) []
project (VSusp i k vs) = VSusp i (\v -> project (apply g (k v) vs)) [] project (VSusp i k vs) = VSusp i (\v -> project (apply g (k v) vs)) []
project v = VP v lbl vs project v = VP v lbl vs
@@ -183,8 +215,8 @@ eval g env s (ExtR t1 t2) [] = let (s1,s2) = split s
extend (VR as1) (VR as2) = VR (foldl (\as (lbl,v) -> update lbl v as) as1 as2) extend (VR as1) (VR as2) = VR (foldl (\as (lbl,v) -> update lbl v as) as1 as2)
extend (VRecType as1) (VRecType as2) = VRecType (foldl (\as (lbl,v) -> update lbl v as) as1 as2) extend (VRecType as1) (VRecType as2) = VRecType (foldl (\as (lbl,v) -> update lbl v as) as1 as2)
extend (VFV i fvs) v2 = VFV i [extend v1 v2 | v1 <- fvs] extend (VFV i fvs) v2 = VFV i (mapVariants (`extend` v2) fvs)
extend v1 (VFV i fvs) = VFV i [extend v1 v2 | v2 <- fvs] extend v1 (VFV i fvs) = VFV i (mapVariants (v1 `extend`) fvs)
extend (VMeta i vs) v2 = VSusp i (\v -> extend (apply g v vs) v2) [] extend (VMeta i vs) v2 = VSusp i (\v -> extend (apply g v vs) v2) []
extend v1 (VMeta i vs) = VSusp i (\v -> extend v1 (apply g v vs)) [] extend v1 (VMeta i vs) = VSusp i (\v -> extend v1 (apply g v vs)) []
extend (VSusp i k vs) v2 = VSusp i (\v -> extend (apply g (k v) vs) v2) [] extend (VSusp i k vs) v2 = VSusp i (\v -> extend (apply g (k v) vs) v2) []
@@ -212,12 +244,13 @@ eval g env s (S t1 t2) vs = let (!s1,!s2) = split s
Success tys ws -> case tys of Success tys ws -> case tys of
[ty] -> vtableSelect g v0 ty tvs v2 vs [ty] -> vtableSelect g v0 ty tvs v2 vs
tys -> vtableSelect g v0 (FV (reverse tys)) tvs v2 vs tys -> vtableSelect g v0 (FV (reverse tys)) tvs v2 vs
select (VFV i fvs) = VFV i [select v1 | v1 <- fvs] select (VFV i fvs) = VFV i (mapVariants select fvs)
select (VMeta i vs) = VSusp i (\v -> select (apply g v vs)) [] select (VMeta i vs) = VSusp i (\v -> select (apply g v vs)) []
select (VSusp i k vs) = VSusp i (\v -> select (apply g (k v) vs)) [] select (VSusp i k vs) = VSusp i (\v -> select (apply g (k v) vs)) []
select v1 = v0 select v1 = v0
empty = State Map.empty Map.empty -- FIXME: options=[] is definitely not correct and this shouldn't be using value2termM at all
empty = State Map.empty Map.empty []
in select v1 in select v1
eval g env s (Let (x,(_,t1)) t2) vs = let (!s1,!s2) = split s eval g env s (Let (x,(_,t1)) t2) vs = let (!s1,!s2) = split s
@@ -234,8 +267,8 @@ eval g env s (C t1 t2) [] = let (!s1,!s2) = split s
concat v1 VEmpty = v1 concat v1 VEmpty = v1
concat VEmpty v2 = v2 concat VEmpty v2 = v2
concat (VFV i fvs) v2 = VFV i [concat v1 v2 | v1 <- fvs] concat (VFV i fvs) v2 = VFV i (mapVariants (`concat` v2) fvs)
concat v1 (VFV i fvs) = VFV i [concat v1 v2 | v2 <- fvs] concat v1 (VFV i fvs) = VFV i (mapVariants (v1 `concat`) fvs)
concat (VMeta i vs) v2 = VSusp i (\v -> concat (apply g v vs) v2) [] concat (VMeta i vs) v2 = VSusp i (\v -> concat (apply g v vs) v2) []
concat v1 (VMeta i vs) = VSusp i (\v -> concat v1 (apply g v vs)) [] concat v1 (VMeta i vs) = VSusp i (\v -> concat v1 (apply g v vs)) []
concat (VSusp i k vs) v2 = VSusp i (\v -> concat (apply g (k v) vs) v2) [] concat (VSusp i k vs) v2 = VSusp i (\v -> concat (apply g (k v) vs) v2) []
@@ -257,8 +290,8 @@ eval g env s (Glue t1 t2) [] = let (!s1,!s2) = split s
glue v (VAlts d vas) = VAlts (glue v d) [(glue v v',ss) | (v',ss) <- vas] glue v (VAlts d vas) = VAlts (glue v d) [(glue v v',ss) | (v',ss) <- vas]
glue (VAlts d vas) (VStr s) = pre d vas s glue (VAlts d vas) (VStr s) = pre d vas s
glue (VAlts d vas) v = glue d v glue (VAlts d vas) v = glue d v
glue (VFV i fvs) v2 = VFV i [glue v1 v2 | v1 <- fvs] glue (VFV i fvs) v2 = VFV i (mapVariants (`glue` v2) fvs)
glue v1 (VFV i fvs) = VFV i [glue v1 v2 | v2 <- fvs] glue v1 (VFV i fvs) = VFV i (mapVariants (v1 `glue`) fvs)
glue (VMeta i vs) v2 = VSusp i (\v -> glue (apply g v vs) v2) [] glue (VMeta i vs) v2 = VSusp i (\v -> glue (apply g v vs) v2) []
glue v1 (VMeta i vs) = VSusp i (\v -> glue v1 (apply g v vs)) [] glue v1 (VMeta i vs) = VSusp i (\v -> glue v1 (apply g v vs)) []
glue (VSusp i k vs) v2 = VSusp i (\v -> glue (apply g (k v) vs) v2) [] glue (VSusp i k vs) v2 = VSusp i (\v -> glue (apply g (k v) vs) v2) []
@@ -279,7 +312,7 @@ eval g env s (ELincat c ty) [] = let lbl = lockLabel c
eval g env s (ELin c t) [] = let lbl = lockLabel c eval g env s (ELin c t) [] = let lbl = lockLabel c
lt = R [] lt = R []
in eval g env s (ExtR t (R [(lbl,(Nothing,lt))])) [] in eval g env s (ExtR t (R [(lbl,(Nothing,lt))])) []
eval g env s (FV ts) vs = VFV s (mapC (\s t -> eval g env s t vs) s ts) eval g env s (FV ts) vs = VFV s (VarFree (mapC (\s t -> eval g env s t vs) s ts))
eval g env s (Alts d as) [] = let (!s1,!s2) = split s eval g env s (Alts d as) [] = let (!s1,!s2) = split s
vd = eval g env s1 d [] vd = eval g env s1 d []
vas = mapC (\s (t1,t2) -> let (!s1,!s2) = split s vas = mapC (\s (t1,t2) -> let (!s1,!s2) = split s
@@ -298,19 +331,20 @@ eval g env c t@(Opts n cs) vs = if null cs
else let (c1,c2,c3) = split3 c else let (c1,c2,c3) = split3 c
vn = eval g env c1 n [] vn = eval g env c1 n []
vcs = mapC evalOpt c cs vcs = mapC evalOpt c cs
in VOpts c3 vn vcs 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) where evalOpt c' (l,t) = let (c1,c2) = split c' in (eval g env c1 l [], eval g env c2 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
evalPredef g@(Gl gr pds) c n args = case Map.lookup n pds of evalPredef g@(Gl gr pds) c n args =
Nothing -> VApp c (cPredef,n) args case Map.lookup n pds of
Just def -> let valueOf (Const res) = res Nothing -> VApp c (cPredef,n) args
valueOf (CFV i vs) = VFV i (map valueOf vs) Just def -> let valueOf (Const res) = res
valueOf (CSusp i k) = VSusp i (valueOf . k) [] valueOf (CFV i vs) = VFV i (consts2variants valueOf vs)
valueOf RunTime = VApp c (cPredef,n) args valueOf (CSusp i k) = VSusp i (valueOf . k) []
valueOf NonExist = VApp c (cPredef,cNonExist) [] valueOf RunTime = VApp c (cPredef,n) args
in valueOf (runPredef def g c args) valueOf NonExist = VApp c (cPredef,cNonExist) []
in valueOf (runPredef def g c args)
stdPredef :: Globals -> PredefTable stdPredef :: Globals -> PredefTable
stdPredef g = Map.fromList stdPredef g = Map.fromList
@@ -340,11 +374,15 @@ apply g (VApp c f@(m,n) vs0) vs
| m == cPredef = evalPredef g c n (vs0++vs) | m == cPredef = evalPredef g c n (vs0++vs)
| otherwise = VApp c f (vs0++vs) | otherwise = VApp c f (vs0++vs)
apply g (VGen i vs0) vs = VGen i (vs0++vs) apply g (VGen i vs0) vs = VGen i (vs0++vs)
apply g (VFV i fvs) vs = VFV i [apply g v vs | v <- fvs] apply g (VFV i fvs) vs = VFV i (mapVariants (\v -> apply g v vs) fvs)
apply g (VS v1 v2 vs') vs = VS v1 v2 (vs'++vs) 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
= BubbleFree Int
| BubbleOpts Value [Value]
bubble v = snd (bubble v) bubble v = snd (bubble v)
where where
bubble (VApp c f vs) = liftL (VApp c f) vs bubble (VApp c f vs) = liftL (VApp c f) vs
@@ -370,9 +408,12 @@ bubble v = snd (bubble v)
bubble (VGlue v1 v2) = lift2 VGlue v1 v2 bubble (VGlue v1 v2) = lift2 VGlue v1 v2
bubble v@(VPatt _ _ _) = lift0 v bubble v@(VPatt _ _ _) = lift0 v
bubble (VPattType v) = lift1 VPattType v bubble (VPattType v) = lift1 VPattType v
bubble (VFV c vs) = bubble (VFV c (VarFree vs)) =
let (union,vs') = mapAccumL descend Map.empty vs let (union,vs') = mapAccumL descend Map.empty vs
in (Map.insert c (length vs,1) union, addVariants (VFV c vs') union) in (Map.insert c (BubbleFree (length vs),1) union, addVariants (VFV c (VarFree vs')) union)
bubble (VFV c (VarOpts n os)) =
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 (VAlts v vs) = lift1L2 VAlts v vs
bubble (VStrs vs) = liftL VStrs vs bubble (VStrs vs) = liftL VStrs vs
bubble (VMarkup tag attrs vs) = bubble (VMarkup tag attrs vs) =
@@ -435,7 +476,7 @@ bubble v = snd (bubble v)
let (choices,v') = bubble v let (choices,v') = bubble v
in (mergeChoices1 union choices,v') in (mergeChoices1 union choices,v')
descend' :: Map.Map Choice (Int,Int) -> (a,Value) -> (Map.Map Choice (Int,Int),(a,Value)) descend' :: Map.Map Choice (BubbleVariants,Int) -> (a,Value) -> (Map.Map Choice (BubbleVariants,Int),(a,Value))
descend' union (x,v) = descend' union (x,v) =
let (choices,v') = bubble v let (choices,v') = bubble v
in (mergeChoices1 union choices,(x,v')) in (mergeChoices1 union choices,(x,v'))
@@ -455,8 +496,10 @@ bubble v = snd (bubble v)
addVariants v = Map.foldrWithKey addVariant v addVariants v = Map.foldrWithKey addVariant v
where where
addVariant c (n,cnt) v addVariant c (bvs,cnt) v
| cnt > 1 = VFV c (replicate n v) | cnt > 1 = VFV c $ case bvs of
BubbleFree k -> VarFree (replicate k v)
BubbleOpts n os -> VarOpts n ((,v) <$> os)
| otherwise = v | otherwise = v
unitfy = fmap (\(n,_) -> (n,1)) unitfy = fmap (\(n,_) -> (n,1))
@@ -507,7 +550,7 @@ patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
(p, VMeta i vs) -> VSusp i (\v -> match' env p ps eqs (apply g v vs) args) [] (p, VMeta i vs) -> VSusp i (\v -> match' env p ps eqs (apply g v vs) args) []
(p, VGen i vs) -> v0 (p, VGen i vs) -> v0
(p, VSusp i k vs) -> VSusp i (\v -> match' env p ps eqs (apply g (k v) vs) args) [] (p, VSusp i k vs) -> VSusp i (\v -> match' env p ps eqs (apply g (k v) vs) args) []
(p, VFV s vs) -> VFV s [match' env p ps eqs arg args | arg <- vs] (p, VFV s vs) -> VFV s (mapVariants (\arg -> match' env p ps eqs arg args) vs)
(PP q qs, VApp c r vs) (PP q qs, VApp c r vs)
| q == r -> match env (qs++ps) eqs (vs++args) | q == r -> match env (qs++ps) eqs (vs++args)
(PR pas, VR as) -> matchRec env (reverse pas) as ps eqs args (PR pas, VR as) -> matchRec env (reverse pas) as ps eqs args
@@ -566,7 +609,7 @@ vtableSelect g v0 ty cs v2 vs =
where where
select (Const (i,_)) = cs !! i select (Const (i,_)) = cs !! i
select (CSusp i k) = VSusp i (\v -> select (k v)) [] select (CSusp i k) = VSusp i (\v -> select (k v)) []
select (CFV s vs) = VFV s (map select vs) select (CFV s vs) = VFV s (consts2variants select vs)
select _ = v0 select _ = v0
value2index (VMeta i vs) ty = CSusp i (\v -> value2index (apply g v vs) ty) value2index (VMeta i vs) ty = CSusp i (\v -> value2index (apply g v vs) ty)
@@ -606,7 +649,7 @@ vtableSelect g v0 ty cs v2 vs =
Gl gr _ = g Gl gr _ = g
value2index (VInt n) ty value2index (VInt n) ty
| Just max <- isTypeInts ty = Const (fromIntegral n,fromIntegral max+1) | Just max <- isTypeInts ty = Const (fromIntegral n,fromIntegral max+1)
value2index (VFV i vs) ty = CFV i [value2index v ty | v <- vs] value2index (VFV i vs) ty = CFV i (variants2consts (\v -> value2index v ty) vs)
value2index v ty = RunTime value2index v ty = RunTime
@@ -624,15 +667,21 @@ data MetaState
| Residuation Scope (Maybe Constraint) | Residuation Scope (Maybe Constraint)
data OptionInfo data OptionInfo
= OptionInfo = OptionInfo
{ optLabel :: Value { optChoice :: Choice
, optLabel :: Value
, optChoices :: [Value] , optChoices :: [Value]
} }
type ChoiceMap = Map.Map Choice Int
data State data State
= State = State
{ choices :: Map.Map Choice Int { choices :: ChoiceMap
, metaVars :: Map.Map MetaId MetaState , metaVars :: Map.Map MetaId MetaState
, options :: [OptionInfo] , options :: [OptionInfo]
} }
cleanOptions :: [OptionInfo] -> ChoiceMap -> ChoiceMap
cleanOptions opts = Map.filterWithKey (\k _ -> any (\opt -> k == optChoice opt) opts)
type Cont r = State -> r -> [Message] -> CheckResult r [Message] type Cont r = State -> r -> [Message] -> CheckResult r [Message]
newtype EvalM a = EvalM (forall r . Globals -> (a -> Cont r) -> Cont r) newtype EvalM a = EvalM (forall r . Globals -> (a -> Cont r) -> Cont r)
@@ -668,7 +717,15 @@ runEvalM g (EvalM f) = Check $ \(es,ws) ->
Fail msg ws -> Fail msg (es,ws) Fail msg ws -> Fail msg (es,ws)
Success xs ws -> Success (reverse xs) (es,ws) Success xs ws -> Success (reverse xs) (es,ws)
where where
empty = State Map.empty Map.empty empty = State Map.empty Map.empty []
runEvalMWithOpts :: Globals -> ChoiceMap -> EvalM a -> Check [(a, ChoiceMap, [OptionInfo])]
runEvalMWithOpts g cs (EvalM f) = Check $ \(es,ws) ->
case f g (\x (State cs mvs os) xs ws -> Success ((x,cs,reverse os):xs) ws) init [] ws of
Fail msg ws -> Fail msg (es,ws)
Success xs ws -> Success (reverse xs) (es,ws)
where
init = State cs Map.empty []
reset :: EvalM a -> EvalM [a] reset :: EvalM a -> EvalM [a]
reset (EvalM f) = EvalM $ \g k state r ws -> reset (EvalM f) = EvalM $ \g k state r ws ->
@@ -683,29 +740,29 @@ variants :: Choice -> [a] -> EvalM a
variants c xs = EvalM (\g k state@(State choices metas opts) r msgs -> variants c xs = EvalM (\g k state@(State choices metas opts) r msgs ->
case Map.lookup c choices of case Map.lookup c choices of
Just j -> k (xs !! j) state r msgs Just j -> k (xs !! j) state r msgs
Nothing -> backtrack 0 xs k choices metas r msgs) Nothing -> backtrack 0 xs k choices metas opts r msgs)
where where
backtrack j [] k choices metas r msgs = Success r msgs backtrack j [] k choices metas opts r msgs = Success r msgs
backtrack j (x:xs) k choices metas r msgs = backtrack j (x:xs) k choices metas opts r msgs =
case k x (State (Map.insert c j choices) metas) r msgs of case k x (State (Map.insert c j choices) metas opts) r msgs of
Fail msg msgs -> Fail msg msgs Fail msg msgs -> Fail msg msgs
Success r msgs -> backtrack (j+1) xs k choices metas r msgs Success r msgs -> backtrack (j+1) xs k choices metas opts r msgs
variants' :: Choice -> (a -> EvalM Term) -> [a] -> EvalM Term variants' :: Choice -> (a -> EvalM Term) -> [a] -> EvalM Term
variants' c f xs = EvalM (\g k state@(State choices metas opts) r msgs -> variants' c f xs = EvalM (\g k state@(State choices metas opts) r msgs ->
case Map.lookup c choices of case Map.lookup c choices of
Just j -> case f (xs !! j) of Just j -> case f (xs !! j) of
EvalM f -> f g k state r msgs EvalM f -> f g k state r msgs
Nothing -> case backtrack g 0 xs choices metas [] msgs of Nothing -> case backtrack g 0 xs choices metas opts [] msgs of
Fail msg msgs -> Fail msg msgs Fail msg msgs -> Fail msg msgs
Success ts msgs -> k (FV (reverse ts)) state r msgs) Success ts msgs -> k (FV (reverse ts)) state r msgs)
where where
backtrack g j [] choices metas ts msgs = Success ts msgs backtrack g j [] choices metas opts ts msgs = Success ts msgs
backtrack g j (x:xs) choices metas ts msgs = backtrack g j (x:xs) choices metas opts ts msgs =
case f x of case f x of
EvalM f -> case f g (\t st ts msgs -> Success (t:ts) msgs) (State (Map.insert c j choices) metas) ts msgs of EvalM f -> case f g (\t st ts msgs -> Success (t:ts) msgs) (State (Map.insert c j choices) metas opts) ts msgs of
Fail msg msgs -> Fail msg msgs Fail msg msgs -> Fail msg msgs
Success ts msgs -> backtrack g (j+1) xs choices metas ts msgs Success ts msgs -> backtrack g (j+1) xs choices metas opts ts msgs
try :: (a -> EvalM b) -> [a] -> Message -> EvalM b try :: (a -> EvalM b) -> [a] -> Message -> EvalM b
try f xs msg = EvalM (\g k state r msgs -> try f xs msg = EvalM (\g k state r msgs ->
@@ -730,7 +787,7 @@ try f xs msg = EvalM (\g k state r msgs ->
newResiduation :: Scope -> EvalM MetaId newResiduation :: Scope -> EvalM MetaId
newResiduation scope = EvalM (\g k (State choices metas opts) r msgs -> newResiduation scope = EvalM (\g k (State choices metas opts) r msgs ->
let meta_id = Map.size metas+1 let meta_id = Map.size metas+1
in k meta_id (State choices (Map.insert meta_id (Residuation scope Nothing) metas)) r msgs) in k meta_id (State choices (Map.insert meta_id (Residuation scope Nothing) metas) opts) r msgs)
getMeta :: MetaId -> EvalM MetaState getMeta :: MetaId -> EvalM MetaState
getMeta i = EvalM (\g k state r msgs -> getMeta i = EvalM (\g k state r msgs ->
@@ -740,7 +797,7 @@ getMeta i = EvalM (\g k state r msgs ->
setMeta :: MetaId -> MetaState -> EvalM () setMeta :: MetaId -> MetaState -> EvalM ()
setMeta i ms = EvalM (\g k (State choices metas opts) r msgs -> setMeta i ms = EvalM (\g k (State choices metas opts) r msgs ->
let state' = State choices (Map.insert i ms metas) let state' = State choices (Map.insert i ms metas) opts
in k () state' r msgs) in k () state' r msgs)
value2termM :: Bool -> [Ident] -> Value -> EvalM Term value2termM :: Bool -> [Ident] -> Value -> EvalM Term
@@ -848,11 +905,18 @@ value2termM flat xs (VGlue v1 v2) = do
t1 <- value2termM flat xs v1 t1 <- value2termM flat xs v1
t2 <- value2termM flat xs v2 t2 <- value2termM flat xs v2
return (Glue t1 t2) return (Glue t1 t2)
value2termM flat xs (VFV i vs) = value2termM True xs (VFV i (VarFree vs)) = do
case flat of v <- variants i vs
True -> do 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
False -> variants' i (value2termM False xs) vs value2termM flat xs (VFV i (VarOpts 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)
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) value2termM flat xs (VPatt min max p) = return (EPatt min max p)
value2termM flat xs (VPattType v) = do t <- value2termM flat xs v value2termM flat xs (VPattType v) = do t <- value2termM flat xs v
return (EPattType t) return (EPattType t)
@@ -942,7 +1006,7 @@ 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) vs)))) ppValue q d (VFV i vs) = prec d 4 ("variants" <+> pp i <+> braces (fsep (punctuate ';' (map (ppValue q 0) (unvariants vs)))))
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"
@@ -972,7 +1036,7 @@ value2string' g VEmpty b ws qs = Const (b,ws,qs)
value2string' g (VC v1 v2) b ws qs = concat v1 (value2string' g v2 b ws qs) value2string' g (VC v1 v2) b ws qs = concat v1 (value2string' g v2 b ws qs)
where where
concat v1 (Const (b,ws,qs)) = value2string' g v1 b ws qs concat v1 (Const (b,ws,qs)) = value2string' g v1 b ws qs
concat v1 (CFV i vs) = CFV i [concat v1 v2 | v2 <- vs] concat v1 (CFV i vs) = CFV i (mapConstVs (concat v1) vs)
concat v1 res = res concat v1 res = res
value2string' g (VApp c q []) b ws qs value2string' g (VApp c q []) b ws qs
| q == (cPredef,cNonExist) = NonExist | q == (cPredef,cNonExist) = NonExist
@@ -1006,7 +1070,7 @@ value2string' g (VAlts vd vas) b ws qs =
| or [startsWith s w | VStr s <- ss] = value2string' g v | or [startsWith s w | VStr s <- ss] = value2string' g v
| otherwise = pre vd vas w | otherwise = pre vd vas w
value2string' g (VFV s vs) b ws qs = value2string' g (VFV s vs) b ws qs =
CFV s [value2string' g v b ws qs | v <- vs] CFV s (variants2consts (\v -> value2string' g v b ws qs) vs)
value2string' _ _ _ _ _ = RunTime value2string' _ _ _ _ _ = RunTime
startsWith [] _ = True startsWith [] _ = True
@@ -1023,10 +1087,11 @@ string2value' (w:ws) = VC (VStr w) (string2value' ws)
value2int g (VMeta i vs) = CSusp i (\v -> value2int g (apply g v vs)) value2int g (VMeta i vs) = CSusp i (\v -> value2int g (apply g v vs))
value2int g (VSusp i k vs) = CSusp i (\v -> value2int g (apply g (k v) vs)) value2int g (VSusp i k vs) = CSusp i (\v -> value2int g (apply g (k v) vs))
value2int g (VInt n) = Const n value2int g (VInt n) = Const n
value2int g (VFV s vs) = CFV s (map (value2int g) vs) value2int g (VFV s vs) = CFV s (variants2consts (value2int g) vs)
value2int g _ = RunTime value2int g _ = RunTime
newtype Choice = Choice Integer deriving (Eq,Ord,Pretty,Show) newtype Choice = Choice { unchoice :: Integer }
deriving (Eq,Ord,Pretty,Show)
unit :: Choice unit :: Choice
unit = Choice 1 unit = Choice 1

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

@@ -1,24 +1,40 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase, TupleSections, NamedFieldPuns #-}
module GF.Compile.Repl (ReplOpts(..), defaultReplOpts, replOptDescrs, getReplOpts, runRepl, runRepl') where module GF.Compile.Repl (ReplOpts(..), defaultReplOpts, replOptDescrs, getReplOpts, runRepl, runRepl') where
import Control.Monad (unless, forM_, foldM) import Control.Monad (join, when, unless, forM_, foldM)
import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (MonadIO)
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.Function ((&)) import Data.Function ((&))
import Data.Functor ((<&>)) import Data.Functor ((<&>))
import Data.List (find)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Text.Read (readMaybe)
import System.Console.GetOpt (ArgOrder(RequireOrder), OptDescr(..), ArgDescr(..), getOpt, usageInfo) import System.Console.GetOpt (ArgOrder(RequireOrder), OptDescr(..), ArgDescr(..), getOpt, usageInfo)
import System.Console.Haskeline (InputT, Settings(..), noCompletion, runInputT, getInputLine, outputStrLn) import System.Console.Haskeline (InputT, Settings(..), noCompletion, runInputT, getInputLine, outputStrLn)
import System.Directory (getAppUserDataDirectory) import System.Directory (getAppUserDataDirectory)
import GF.Compile (batchCompile) import GF.Compile (batchCompile)
import GF.Compile.Compute.Concrete2 (Globals(Gl), stdPredef, normalFlatForm) import GF.Compile.Compute.Concrete2
( Choice(..)
, ChoiceMap
, Globals(Gl)
, OptionInfo(..)
, stdPredef
, unit
, eval
, cleanOptions
, runEvalMWithOpts
, value2termM
, ppValue
)
import GF.Compile.Rename (renameSourceTerm) import GF.Compile.Rename (renameSourceTerm)
import GF.Compile.TypeCheck.ConcreteNew (inferLType) import GF.Compile.TypeCheck.ConcreteNew (inferLType)
import GF.Data.ErrM (Err(..)) import GF.Data.ErrM (Err(..))
import GF.Data.Utilities (maybeAt, orLeft)
import GF.Grammar.Grammar import GF.Grammar.Grammar
( Grammar ( Grammar
, mGrammar , mGrammar
@@ -47,10 +63,16 @@ data ReplOpts = ReplOpts
{ lang :: Lang { lang :: Lang
, noPrelude :: Bool , noPrelude :: Bool
, inputFiles :: [String] , inputFiles :: [String]
, evalToFlat :: Bool
} }
defaultReplOpts :: ReplOpts defaultReplOpts :: ReplOpts
defaultReplOpts = ReplOpts GF False [] defaultReplOpts = ReplOpts
{ lang = GF
, noPrelude = False
, inputFiles = []
, evalToFlat = True
}
type Errs a = Either [String] a type Errs a = Either [String] a
type ReplOptsOp = ReplOpts -> Errs ReplOpts type ReplOptsOp = ReplOpts -> Errs ReplOpts
@@ -66,6 +88,7 @@ replOptDescrs =
_ -> Left ["Unknown language variant: " ++ s]) _ -> Left ["Unknown language variant: " ++ s])
"{gf,bnfc,nlg}") "{gf,bnfc,nlg}")
"Set the active language variant." "Set the active language variant."
, Option [] ["no-flat"] (flag $ \o -> o { evalToFlat = False }) "Do not evaluate to flat form."
] ]
where where
flag f = NoArg $ \o -> pure (f o) flag f = NoArg $ \o -> pure (f o)
@@ -77,12 +100,14 @@ getReplOpts args = case errs of
where where
(flags, inputFiles, errs) = getOpt RequireOrder replOptDescrs args (flags, inputFiles, errs) = getOpt RequireOrder replOptDescrs args
execCheck :: MonadIO m => Check a -> (a -> InputT m ()) -> InputT m () execCheck :: MonadIO m => Check a -> (a -> InputT m b) -> InputT m (Maybe b)
execCheck c k = case runCheck c of execCheck c k = case runCheck c of
Ok (a, warn) -> do Ok (a, warn) -> do
unless (null warn) $ outputStrLn warn unless (null warn) $ outputStrLn warn
k a Just <$> k a
Bad err -> outputStrLn err Bad err -> do
outputStrLn err
return Nothing
replModNameStr :: String replModNameStr :: String
replModNameStr = "<repl>" replModNameStr = "<repl>"
@@ -90,47 +115,182 @@ replModNameStr = "<repl>"
replModName :: ModuleName replModName :: ModuleName
replModName = moduleNameS replModNameStr replModName = moduleNameS replModNameStr
parseThen :: MonadIO m => Lang -> Grammar -> String -> (Term -> InputT m ()) -> InputT m () parseThen :: MonadIO m => Lang -> Grammar -> String -> (Term -> InputT m b) -> InputT m (Maybe b)
parseThen l g s k = case runLangP l pTerm (BS.pack s) of parseThen l g s k = case runLangP l pTerm (BS.pack s) of
Left (Pn l c, err) -> outputStrLn $ err ++ " (" ++ show l ++ ":" ++ show c ++ ")" Left (Pn l c, err) -> do
outputStrLn $ err ++ " (" ++ show l ++ ":" ++ show c ++ ")"
return Nothing
Right t -> execCheck (renameSourceTerm g replModName t) $ \t -> k t Right t -> execCheck (renameSourceTerm g replModName t) $ \t -> k t
runRepl' :: Lang -> Globals -> IO () data ResultState = ResultState
runRepl' l gl@(Gl g _) = do { srsResult :: Term
historyFile <- getAppUserDataDirectory "gfci_history" , srsChoices :: ChoiceMap
runInputT (Settings noCompletion (Just historyFile) True) repl -- TODO tab completion , srsOptInfo :: [OptionInfo]
where , srsOpts :: ChoiceMap
repl = do }
getInputLine "gfci> " >>= \case data OptionState = OptionState
Nothing -> repl { osTerm :: Term
Just (':' : l) -> let (cmd, arg) = break isSpace l in command cmd (dropWhile isSpace arg) , osResults :: [ResultState]
Just code -> evalPrintLoop code , osSelected :: Maybe ResultState
}
newtype ReplState = ReplState
{ rsOpts :: Maybe OptionState
}
command "t" arg = do initState :: ReplState
parseThen l g arg $ \main -> initState = ReplState Nothing
runRepl' :: ReplOpts -> Globals -> IO ()
runRepl' opts@ReplOpts { lang, evalToFlat } gl@(Gl g _) = do
historyFile <- getAppUserDataDirectory "gfci_history"
runInputT (Settings noCompletion (Just historyFile) True) (repl initState) -- TODO tab completion
where
repl st = do
getInputLine "gfci> " >>= \case
Nothing -> repl st
Just (':' : l) -> let (cmd, arg) = break isSpace l in command st cmd (dropWhile isSpace arg)
Just code -> evalPrintLoop st code
nlrepl st = outputStrLn "" >> repl st
-- Show help text
command st "?" arg = do
outputStrLn ":? -- show help text."
outputStrLn ":t <expr> -- show the inferred type of <expr>."
outputStrLn ":r -- show the results of the last eval."
outputStrLn ":s <index> -- select the result at <index>."
outputStrLn ":c -- show the current selected result."
outputStrLn ":o <choice> <value> -- set option <choice> to <value>."
outputStrLn ":q -- quit the REPL."
nlrepl st
-- Show the inferred type of an expression
command st "t" arg = do
parseThen lang g arg $ \main ->
execCheck (inferLType gl main) $ \res -> execCheck (inferLType gl main) $ \res ->
forM_ res $ \(t, ty) -> forM_ res $ \(t, ty) ->
let t' = case t of let t' = case t of
Typed _ _ -> t Typed _ _ -> t
t -> Typed t ty t -> Typed t ty
in outputStrLn $ render (ppTerm Unqualified 0 t') in outputStrLn $ render (ppTerm Unqualified 0 t')
outputStrLn "" >> repl nlrepl st
command "q" _ = outputStrLn "Bye!" -- Show the results of the last evaluated expression
command st "r" arg = do
case rsOpts st of
Nothing -> do
outputStrLn "No results to show!"
Just (OptionState t rs _) -> do
outputStrLn $ "> " ++ render (ppTerm Unqualified 0 t)
outputResults rs
nlrepl st
command cmd _ = do -- Select a result to "focus" by its index
outputStrLn $ "Unknown REPL command: " ++ cmd command st "s" arg = do
outputStrLn "" >> repl let e = do (OptionState t rs _) <- orLeft "No results to select!" $ rsOpts st
s <- orLeft "Could not parse result index!" $ readMaybe arg
(ResultState r cs ois os) <- orLeft "Result index out of bounds!" $ rs `maybeAt` (s - 1)
return (t, rs, r, cs, ois, os)
case e of
Left err -> do
outputStrLn err
nlrepl st
Right (t, rs, r, cs, ois, os) -> do
outputStrLn $ render (ppTerm Unqualified 0 r)
outputOptions ois os
nlrepl (st { rsOpts = Just (OptionState t rs (Just (ResultState r cs ois os))) })
evalPrintLoop code = do -- TODO bindings -- Show the current selected result
parseThen l g code $ \main -> command st "c" arg = do
execCheck (inferLType gl main >>= \((t, _):_) -> normalFlatForm gl t) $ \nfs -> let e = do (OptionState t _ sel) <- orLeft "No results to select!" $ rsOpts st
forM_ (zip [1..] nfs) $ \(i, nf) -> (ResultState r _ ois os) <- orLeft "No result selected!" sel
outputStrLn $ show i ++ ". " ++ render (ppTerm Unqualified 0 nf) return (t, r, ois, os)
outputStrLn "" >> repl case e of
Left err -> outputStrLn err
Right (t, r, ois, os) -> do
outputStrLn $ "> " ++ render (ppTerm Unqualified 0 t)
outputStrLn $ render (ppTerm Unqualified 0 r)
outputOptions ois os
nlrepl st
-- Set an option for the selected result
command st "o" arg = do
let e = do (OptionState t _ sel) <- orLeft "No results to select!" $ rsOpts st
(ResultState _ cs ois os) <- orLeft "No result selected!" sel
(c, i) <- case words arg of
[argc, argi] -> do
c <- orLeft "Could not parse option choice!" $ readMaybe argc
i <- orLeft "Could not parse option value!" $ readMaybe argi
return (c, i)
_ -> Left "Expected two arguments!"
when (i < 1) $ Left "Option value must be positive!"
oi <- orLeft "No such option!" $ find (\oi -> unchoice (optChoice oi) == c) ois
when (i > length (optChoices oi)) $ Left "Option value out of bounds!"
return (t, cs, ois, os, c, i)
case e of
Left err -> do
outputStrLn err
nlrepl st
Right (t, cs, ois, os, c, i) -> do
let os' = Map.insert (Choice c) (i - 1) os
nfs <- execCheck (doEval st t (Map.union os' cs)) pure
case nfs of
Nothing -> nlrepl st
Just [] -> do
outputStrLn "No results!"
nlrepl st
Just [(r, cs, ois')] -> do
outputStrLn $ render (ppTerm Unqualified 0 r)
let os'' = cleanOptions ois' os'
outputOptions ois' os''
let rst = ResultState r (Map.difference cs os') ois' os''
nlrepl (st { rsOpts = Just (OptionState t [rst] (Just rst)) })
Just rs -> do
let rsts = rs <&> \(r, cs, ois') ->
ResultState r (Map.difference cs os') ois' (cleanOptions ois' os')
outputResults rsts
nlrepl (st { rsOpts = Just (OptionState t rsts Nothing) })
-- Quit the REPL
command _ "q" _ = outputStrLn "Bye!"
command st cmd _ = do
outputStrLn $ "Unknown REPL command \"" ++ cmd ++ "\"! Use :? for help."
nlrepl st
evalPrintLoop st code = do -- TODO bindings
c <- parseThen lang g code $ \main -> do
rsts <- execCheck (doEval st main Map.empty) $ \nfs -> do
if null nfs then do
outputStrLn "No results!"
return Nothing
else do
let rsts = nfs <&> \(r, cs, ois) -> ResultState r cs ois Map.empty
outputResults rsts
return $ Just rsts
return $ (main,) <$> join rsts
case join c of
Just (t, rs) -> nlrepl (ReplState (Just (OptionState t rs Nothing)))
Nothing -> nlrepl st
doEval st t opts = inferLType gl t >>= \case
[] -> fail $ "No result while checking type: " ++ render (ppTerm Unqualified 0 t)
((t', _):_) -> runEvalMWithOpts gl opts (value2termM evalToFlat [] (eval gl [] unit t' []))
outputResults rs =
forM_ (zip [1..] rs) $ \(i, ResultState r _ opts _) ->
outputStrLn $ show i ++ (if null opts then ". " else "*. ") ++ render (ppTerm Unqualified 0 r)
outputOptions ois os =
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) ->
outputStrLn $ (if i == sel then "->" else " ") ++ show i ++ ". " ++ render (ppValue Unqualified 0 l)
runRepl :: ReplOpts -> IO () runRepl :: ReplOpts -> IO ()
runRepl (ReplOpts lang noPrelude inputFiles) = do runRepl opts@ReplOpts { noPrelude, inputFiles } = do
-- TODO accept an ngf grammar -- TODO accept an ngf grammar
let toLoad = if noPrelude then inputFiles else "prelude/Predef.gfo" : inputFiles let toLoad = if noPrelude then inputFiles else "prelude/Predef.gfo" : inputFiles
(g0, opens) <- case toLoad of (g0, opens) <- case toLoad of
@@ -152,4 +312,4 @@ runRepl (ReplOpts lang noPrelude inputFiles) = do
, jments = Map.empty , jments = Map.empty
} }
g = Gl (prependModule g0 (replModName, modInfo)) (if noPrelude then Map.empty else stdPredef g) g = Gl (prependModule g0 (replModName, modInfo)) (if noPrelude then Map.empty else stdPredef g)
runRepl' lang g runRepl' opts g

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

@@ -21,6 +21,7 @@ import Data.STRef
import Data.List (nub, (\\), tails) import Data.List (nub, (\\), tails)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe(fromMaybe,isNothing,mapMaybe) import Data.Maybe(fromMaybe,isNothing,mapMaybe)
import Data.Bifunctor(second)
import Data.Functor((<&>)) import Data.Functor((<&>))
import qualified Control.Monad.Fail as Fail import qualified Control.Monad.Fail as Fail
@@ -747,10 +748,10 @@ subsCheckRho scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do -- Rule REC
"there are no values for fields:" <+> hsep missing) "there are no values for fields:" <+> hsep missing)
rs <- sequence [mkField scope l t ty1 ty2 | (l,ty2,Just ty1) <- fields, Just t <- [mkProj l]] rs <- sequence [mkField scope l t ty1 ty2 | (l,ty2,Just ty1) <- fields, Just t <- [mkProj l]]
return (mkWrap (R rs)) return (mkWrap (R rs))
subsCheckRho scope t tau1 (VFV c vs) = do subsCheckRho scope t tau1 (VFV c (VarFree vs)) = do
tau2 <- variants c vs tau2 <- variants c vs
subsCheckRho scope t tau1 tau2 subsCheckRho scope t tau1 tau2
subsCheckRho scope t (VFV c vs) tau2 = do subsCheckRho scope t (VFV c (VarFree vs)) tau2 = do
tau1 <- variants c vs tau1 <- variants c vs
subsCheckRho scope t tau1 tau2 subsCheckRho scope t tau1 tau2
subsCheckRho scope t tau1 tau2 = do -- Rule EQ subsCheckRho scope t tau1 tau2 = do -- Rule EQ
@@ -834,9 +835,14 @@ supertype scope (Just ctr) ty = do
unifyFun :: Scope -> Rho -> EvalM (BindType, Ident, Sigma, Rho) unifyFun :: Scope -> Rho -> EvalM (BindType, Ident, Sigma, Rho)
unifyFun scope (VProd bt x arg res) = unifyFun scope (VProd bt x arg res) =
return (bt,x,arg,res) return (bt,x,arg,res)
unifyFun scope (VFV c vs) = do unifyFun scope (VFV c (VarFree vs)) = do
res <- mapM (unifyFun scope) vs res <- mapM (unifyFun scope) vs
return (Explicit, identW, VFV c [sigma | (_,_,sigma,rho) <- res], VFV c [rho | (_,_,sigma,rho) <- res]) return
( Explicit
, identW
, VFV c (VarFree [sigma | (_,_,sigma,rho) <- res])
, VFV c (VarFree [rho | (_,_,sigma,rho) <- res])
)
unifyFun scope tau = do unifyFun scope tau = do
let mk_val i = VMeta i [] let mk_val i = VMeta i []
arg <- fmap mk_val $ newResiduation scope arg <- fmap mk_val $ newResiduation scope
@@ -975,7 +981,7 @@ occursCheck scope' i0 scope v =
check m n (VPattType v) = check m n (VPattType v) =
check m n v check m n v
check m n (VFV c vs) = check m n (VFV c vs) =
mapM_ (check m n) vs mapM_ (check m n) (unvariants vs)
check m n (VAlts v vs) = check m n (VAlts v vs) =
check m n v >> mapM_ (\(v1,v2) -> check m n v1 >> check m n v2) vs check m n v >> mapM_ (\(v1,v2) -> check m n v1 >> check m n v2) vs
check m n (VStrs vs) = check m n (VStrs vs) =
@@ -1101,9 +1107,12 @@ quantify scope t tvs ty = do
check m n xs (VPattType v) = do check m n xs (VPattType v) = do
(xs,v) <- check m n xs v (xs,v) <- check m n xs v
return (xs,VPattType v) return (xs,VPattType v)
check m n xs (VFV c 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 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 (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
@@ -1171,7 +1180,7 @@ getMetaVars sc_tys = foldM (\acc (scope,ty) -> go acc ty) [] sc_tys
Residuation _ (Just v) -> go acc v Residuation _ (Just v) -> go acc v
_ -> return acc _ -> return acc
go acc (VApp c f args) = foldM go acc args go acc (VApp c f args) = foldM go acc args
go acc (VFV c vs) = foldM go acc vs go acc (VFV c vs) = foldM go acc (unvariants vs)
go acc (VCRecType vs) = foldM (\acc (lbl,b,v) -> go acc v) acc vs go acc (VCRecType vs) = foldM (\acc (lbl,b,v) -> go acc v) acc vs
go acc (VCInts _ _) = return acc go acc (VCInts _ _) = return acc
go acc v = unimplemented ("go "++show (ppValue Unqualified 5 v)) go acc v = unimplemented ("go "++show (ppValue Unqualified 5 v))

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

@@ -32,6 +32,11 @@ notLongerThan, longerThan :: Int -> [a] -> Bool
notLongerThan n = null . snd . splitAt n notLongerThan n = null . snd . splitAt n
longerThan n = not . notLongerThan n longerThan n = not . notLongerThan n
maybeAt :: [a] -> Int -> Maybe a
maybeAt xs i
| i >= 0 && i < length xs = Just (xs !! i)
| otherwise = Nothing
lookupList :: Eq a => a -> [(a, b)] -> [b] lookupList :: Eq a => a -> [(a, b)] -> [b]
lookupList a [] = [] lookupList a [] = []
lookupList a (p:ps) | a == fst p = snd p : lookupList a ps lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
@@ -171,6 +176,11 @@ anyM p = foldM (\b x -> if b then return True else p x) False
-- * functions on Maybes -- * functions on Maybes
-- | Returns the argument on the right, or a default value on the left.
orLeft :: a -> Maybe b -> Either a b
orLeft a (Just b) = Right b
orLeft a Nothing = Left a
-- | Returns true if the argument is Nothing or Just [] -- | Returns true if the argument is Nothing or Just []
nothingOrNull :: Maybe [a] -> Bool nothingOrNull :: Maybe [a] -> Bool
nothingOrNull = maybe True null nothingOrNull = maybe True null