mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-08-19 10:46:22 -06:00
Merge branch 'majestic' of github.com:krangelov/gf-core into majestic
This commit is contained in:
Krasimir Angelov
@@ -1,14 +1,14 @@
|
||||
{-# LANGUAGE RankNTypes, BangPatterns, GeneralizedNewtypeDeriving, TupleSections #-}
|
||||
|
||||
module GF.Compile.Compute.Concrete2
|
||||
(Env, Scope, Value(..), Variants(..), OptionInfo(..), ChoiceMap, cleanOptions,
|
||||
ConstValue(..), ConstVariants(..), Globals(..), PredefTable, EvalM,
|
||||
mapVariants, mapVariantsC, unvariants, variants2consts, consts2variants,
|
||||
runEvalM, runEvalMWithOpts, stdPredef, globals,
|
||||
(Env, Scope, Value(..), Variants(..), OptionInfo(..),
|
||||
ConstValue(..), Globals(..), PredefTable, EvalM,
|
||||
mapVariantsC, unvariants,
|
||||
runEvalM, runEvalMWithInput, stdPredef, globals,
|
||||
PredefImpl, Predef(..), ($\),
|
||||
pdCanonicalArgs, pdArity,
|
||||
normalForm, normalFlatForm,
|
||||
eval, apply, value2term, value2termM, value2int, value2float, bubble, patternMatch, vtableSelect, State(..),
|
||||
eval, apply, value2term, value2termM, value2string, value2int, value2float, value2expr, string2value, bubble, patternMatch, vtableSelect, State(..),
|
||||
newResiduation, checkpoint, getMeta, setMeta, MetaState(..), variants, try,
|
||||
evalError, evalWarn, ppValue, Choice(..), unit, poison, split, split3, split4, mapC, mapCM) where
|
||||
|
||||
@@ -34,6 +34,7 @@ import Data.Functor ((<&>))
|
||||
import Data.Maybe (fromMaybe,fromJust)
|
||||
import Data.List
|
||||
import Data.Char
|
||||
import PGF2(Expr(..),Literal(..))
|
||||
|
||||
type PredefImpl = Globals -> Choice -> [Value] -> ConstValue Value
|
||||
newtype Predef = Predef { runPredef :: PredefImpl }
|
||||
@@ -83,7 +84,7 @@ data Value
|
||||
| VGlue Value Value
|
||||
| VPatt Int (Maybe Int) Patt
|
||||
| VPattType Value
|
||||
| VFV Choice Variants
|
||||
| VFV Choice (Variants Value)
|
||||
| VAlts Value [(Value, Value)]
|
||||
| VStrs [Value]
|
||||
| VMarkup Ident [(Ident,Value)] [Value]
|
||||
@@ -92,19 +93,19 @@ data Value
|
||||
| VError Doc
|
||||
| VInts Integer Bool
|
||||
|
||||
data Variants
|
||||
= VarFree [Value]
|
||||
| VarOpts Value [(Maybe Value, Value)]
|
||||
data Variants a
|
||||
= VarFree [a]
|
||||
| VarOpts Value [(Value, a)]
|
||||
|
||||
mapVariants :: (Value -> Value) -> Variants -> Variants
|
||||
mapVariants f (VarFree vs) = VarFree (f <$> vs)
|
||||
mapVariants f (VarOpts n cs) = VarOpts n (second f <$> cs)
|
||||
instance Functor Variants where
|
||||
fmap f (VarFree vs) = VarFree (f <$> vs)
|
||||
fmap f (VarOpts n cs) = VarOpts n (second f <$> cs)
|
||||
|
||||
mapVariantsC :: (Choice -> Value -> Value) -> Choice -> Variants -> Variants
|
||||
mapVariantsC :: (Choice -> a -> b) -> Choice -> Variants a -> Variants b
|
||||
mapVariantsC f c (VarFree vs) = VarFree (mapC f c vs)
|
||||
mapVariantsC f c (VarOpts n cs) = VarOpts n (mapC (\c (x,y) -> (x,f c y)) c cs)
|
||||
|
||||
unvariants :: Variants -> [Value]
|
||||
unvariants :: Variants a -> [a]
|
||||
unvariants (VarFree vs) = vs
|
||||
unvariants (VarOpts n cs) = snd <$> cs
|
||||
|
||||
@@ -132,25 +133,13 @@ isCanonicalForm flat _ = False
|
||||
data ConstValue a
|
||||
= Const a
|
||||
| CSusp MetaId (Value -> ConstValue a)
|
||||
| CFV Choice (ConstVariants a)
|
||||
| CFV Choice (Variants (ConstValue a))
|
||||
| RunTime
|
||||
| NonExist
|
||||
|
||||
data ConstVariants a
|
||||
= ConstFree [ConstValue a]
|
||||
| ConstOpts Value [(Maybe 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
|
||||
fmap f (Const c) = Const (f c)
|
||||
fmap f (CFV i vs) = CFV i (mapConstVs (fmap f) vs)
|
||||
fmap f (CFV i vs) = CFV i (fmap (fmap f) vs)
|
||||
fmap f (CSusp i k) = CSusp i (fmap f . k)
|
||||
fmap f RunTime = RunTime
|
||||
fmap f NonExist = NonExist
|
||||
@@ -159,8 +148,8 @@ instance Applicative ConstValue where
|
||||
pure = Const
|
||||
|
||||
(Const f) <*> (Const x) = Const (f x)
|
||||
(CFV s vs) <*> v2 = CFV s (mapConstVs (<*> v2) vs)
|
||||
v1 <*> (CFV s vs) = CFV s (mapConstVs (v1 <*>) vs)
|
||||
(CFV s vs) <*> v2 = CFV s (fmap (<*> v2) vs)
|
||||
v1 <*> (CFV s vs) = CFV s (fmap (v1 <*>) vs)
|
||||
(CSusp i k) <*> v2 = CSusp i (\v -> k v <*> v2)
|
||||
v1 <*> (CSusp i k) = CSusp i (\v -> v1 <*> k v)
|
||||
NonExist <*> _ = NonExist
|
||||
@@ -168,14 +157,6 @@ instance Applicative ConstValue where
|
||||
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 g t = value2term g [] (bubble (eval g [] unit t []))
|
||||
|
||||
@@ -211,7 +192,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 $$
|
||||
"in" <+> pp (P t lbl))
|
||||
Just v -> apply g v vs
|
||||
project (VFV s fvs) = VFV s (mapVariants project fvs)
|
||||
project (VFV s fvs) = VFV s (fmap project fvs)
|
||||
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 v = VP v lbl vs
|
||||
@@ -220,8 +201,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 (VRecType as1 e1) (VRecType as2 e2)=VRecType (foldl (\as (lbl,o,v) -> update3 lbl o v as) as1 as2) (e1 || e2)
|
||||
extend (VFV i fvs) v2 = VFV i (mapVariants (`extend` v2) fvs)
|
||||
extend v1 (VFV i fvs) = VFV i (mapVariants (v1 `extend`) fvs)
|
||||
extend (VFV i fvs) v2 = VFV i (fmap (`extend` v2) fvs)
|
||||
extend v1 (VFV i fvs) = VFV i (fmap (v1 `extend`) fvs)
|
||||
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 (VSusp i k vs) v2 = VSusp i (\v -> extend (apply g (k v) vs) v2) []
|
||||
@@ -249,13 +230,13 @@ eval g env s (S t1 t2) vs = let (!s1,!s2) = split s
|
||||
Success tys ws -> case tys of
|
||||
[ty] -> vtableSelect g v0 ty tvs v2 vs
|
||||
tys -> vtableSelect g v0 (FV (reverse tys)) tvs v2 vs
|
||||
select (VFV i fvs) = VFV i (mapVariants select fvs)
|
||||
select (VFV i fvs) = VFV i (fmap select fvs)
|
||||
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 v1 = v0
|
||||
|
||||
-- FIXME: options=[] is definitely not correct and this shouldn't be using value2termM at all
|
||||
empty = State Map.empty Map.empty []
|
||||
empty = State [] Map.empty Map.empty []
|
||||
|
||||
in select v1
|
||||
eval g env s (Let (x,(_,t1)) t2) vs = let (!s1,!s2) = split s
|
||||
@@ -272,8 +253,8 @@ eval g env s (C t1 t2) [] = let (!s1,!s2) = split s
|
||||
|
||||
concat v1 VEmpty = v1
|
||||
concat VEmpty v2 = v2
|
||||
concat (VFV i fvs) v2 = VFV i (mapVariants (`concat` v2) fvs)
|
||||
concat v1 (VFV i fvs) = VFV i (mapVariants (v1 `concat`) fvs)
|
||||
concat (VFV i fvs) v2 = VFV i (fmap (`concat` v2) fvs)
|
||||
concat v1 (VFV i fvs) = VFV i (fmap (v1 `concat`) fvs)
|
||||
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 (VSusp i k vs) v2 = VSusp i (\v -> concat (apply g (k v) vs) v2) []
|
||||
@@ -295,8 +276,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 (VAlts d vas) (VStr s) = pre d vas s
|
||||
glue (VAlts d vas) v = glue d v
|
||||
glue (VFV i fvs) v2 = VFV i (mapVariants (`glue` v2) fvs)
|
||||
glue v1 (VFV i fvs) = VFV i (mapVariants (v1 `glue`) fvs)
|
||||
glue (VFV i fvs) v2 = VFV i (fmap (`glue` v2) fvs)
|
||||
glue v1 (VFV i fvs) = VFV i (fmap (v1 `glue`) fvs)
|
||||
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 (VSusp i k vs) v2 = VSusp i (\v -> glue (apply g (k v) vs) v2) []
|
||||
@@ -337,8 +318,8 @@ eval g env c t@(Opts n cs) vs = if null cs
|
||||
vn = eval g env c1 n []
|
||||
vcs = mapC evalOpt c cs
|
||||
in VFV c3 (VarOpts vn vcs)
|
||||
where evalOpt c' (Just l, t) = let (c1,c2) = split c' in (Just (eval g env c1 l []), eval g env c2 t vs)
|
||||
evalOpt c' (Nothing,t) = let (c1,c2) = split c' in (Nothing, eval g env c2 t vs)
|
||||
where evalOpt c' (Just l, t) = let (c1,c2) = split c' in (eval g env c1 l [], eval g env c2 t vs)
|
||||
evalOpt c' (Nothing,t) = let v = eval g env c' t vs in (v, v)
|
||||
eval g env c t vs = VError ("Cannot reduce term" <+> pp t)
|
||||
|
||||
evalPredef :: Globals -> Choice -> Ident -> [Value] -> Value
|
||||
@@ -346,7 +327,7 @@ evalPredef g@(Gl gr pds) c n args =
|
||||
case Map.lookup n pds of
|
||||
Nothing -> VApp c (cPredef,n) args
|
||||
Just def -> let valueOf (Const res) = res
|
||||
valueOf (CFV i vs) = VFV i (consts2variants valueOf vs)
|
||||
valueOf (CFV i vs) = VFV i (fmap valueOf vs)
|
||||
valueOf (CSusp i k) = VSusp i (valueOf . k) []
|
||||
valueOf RunTime = VApp c (cPredef,n) args
|
||||
valueOf NonExist = VApp c (cPredef,cNonExist) []
|
||||
@@ -381,7 +362,7 @@ apply g (VApp c f@(m,n) vs0) vs
|
||||
| m == cPredef = evalPredef g c n (vs0++vs)
|
||||
| otherwise = VApp c f (vs0++vs)
|
||||
apply g (VGen i vs0) vs = VGen i (vs0++vs)
|
||||
apply g (VFV i fvs) vs = VFV i (mapVariants (\v -> apply g v vs) fvs)
|
||||
apply g (VFV i fvs) vs = VFV i (fmap (\v -> apply g v vs) fvs)
|
||||
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
|
||||
@@ -424,7 +405,7 @@ bubble v = snd (bubble v)
|
||||
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 (map (\(l,t) -> fromMaybe t l) os),1) union, VFV c (VarOpts n os'))
|
||||
in (Map.insert c (BubbleOpts n (map fst os),1) union, VFV c (VarOpts n os'))
|
||||
bubble (VAlts v vs) = lift1L2 VAlts v vs
|
||||
bubble (VStrs vs) = liftL VStrs vs
|
||||
bubble (VMarkup tag attrs vs) =
|
||||
@@ -509,7 +490,7 @@ bubble v = snd (bubble v)
|
||||
addVariant c (bvs,cnt) v
|
||||
| cnt > 1 = VFV c $ case bvs of
|
||||
BubbleFree k -> VarFree (replicate k v)
|
||||
BubbleOpts n os -> VarOpts n (map (\l -> (Just l,v)) os)
|
||||
BubbleOpts n os -> VarOpts n (map (\l -> (l,v)) os)
|
||||
| otherwise = v
|
||||
|
||||
unitfy = fmap (\(n,_) -> (n,1))
|
||||
@@ -565,7 +546,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, VGen i vs) -> v0
|
||||
(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 (mapVariants (\arg -> match' env p ps eqs arg args) vs)
|
||||
(p, VFV s vs) -> VFV s (fmap (\arg -> match' env p ps eqs arg args) vs)
|
||||
(PP q qs, VApp c r vs)
|
||||
| q == r -> match env (qs++ps) eqs (vs++args)
|
||||
(PR pas, VR as) -> matchRec env (reverse pas) as ps eqs args
|
||||
@@ -624,7 +605,7 @@ vtableSelect g v0 ty cs v2 vs =
|
||||
where
|
||||
select (Const (i,_)) = cs !! i
|
||||
select (CSusp i k) = VSusp i (\v -> select (k v)) []
|
||||
select (CFV s vs) = VFV s (consts2variants select vs)
|
||||
select (CFV c vs) = VFV c (fmap select vs)
|
||||
select _ = v0
|
||||
|
||||
value2index (VMeta i vs) ty = CSusp i (\v -> value2index (apply g v vs) ty)
|
||||
@@ -664,7 +645,7 @@ vtableSelect g v0 ty cs v2 vs =
|
||||
Gl gr _ = g
|
||||
value2index (VInt n) ty
|
||||
| Just max <- isTypeInts ty = Const (fromIntegral n,fromIntegral max+1)
|
||||
value2index (VFV i vs) ty = CFV i (variants2consts (\v -> value2index v ty) vs)
|
||||
value2index (VFV c vs) ty = CFV c (fmap (\v -> value2index v ty) vs)
|
||||
value2index v ty = RunTime
|
||||
|
||||
|
||||
@@ -682,20 +663,18 @@ data MetaState
|
||||
data OptionInfo
|
||||
= OptionInfo
|
||||
{ optChoice :: Choice
|
||||
, optValue :: Int
|
||||
, optLabel :: Value
|
||||
, optChoices :: [Value]
|
||||
}
|
||||
type ChoiceMap = Map.Map Choice Int
|
||||
data State
|
||||
= State
|
||||
{ choices :: ChoiceMap
|
||||
{ input :: [(Choice, Int)]
|
||||
, choices :: Map.Map Choice Int
|
||||
, metaVars :: Map.Map MetaId MetaState
|
||||
, 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]
|
||||
newtype EvalM a = EvalM (forall r . Globals -> (a -> Cont r) -> Cont r)
|
||||
|
||||
@@ -731,15 +710,15 @@ runEvalM g (EvalM f) = Check $ \(es,ws) ->
|
||||
Fail msg ws -> Fail msg (es,ws)
|
||||
Success xs ws -> Success (reverse xs) (es,ws)
|
||||
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
|
||||
runEvalMWithInput :: Globals -> [(Choice,Int)] -> EvalM a -> Check [(a, [OptionInfo])]
|
||||
runEvalMWithInput g input (EvalM f) = Check $ \(es,ws) ->
|
||||
case f g (\x (State _ cs mvs os) xs ws -> Success ((x,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 []
|
||||
init = State input Map.empty Map.empty []
|
||||
|
||||
reset :: EvalM a -> EvalM [a]
|
||||
reset (EvalM f) = EvalM $ \g k state r ws ->
|
||||
@@ -751,32 +730,32 @@ globals :: EvalM Globals
|
||||
globals = EvalM (\g k -> k g)
|
||||
|
||||
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 input choices metas opts) r msgs ->
|
||||
case Map.lookup c choices of
|
||||
Just j -> k (xs !! j) state r msgs
|
||||
Nothing -> backtrack 0 xs k choices metas opts r msgs)
|
||||
Nothing -> backtrack 0 xs k input choices metas opts r msgs)
|
||||
where
|
||||
backtrack j [] k choices metas opts r msgs = Success r msgs
|
||||
backtrack j (x:xs) k choices metas opts r msgs =
|
||||
case k x (State (Map.insert c j choices) metas opts) r msgs of
|
||||
backtrack j [] k input choices metas opts r msgs = Success r msgs
|
||||
backtrack j (x:xs) k input choices metas opts r msgs =
|
||||
case k x (State input (Map.insert c j choices) metas opts) r msgs of
|
||||
Fail msg msgs -> Fail msg msgs
|
||||
Success r msgs -> backtrack (j+1) xs k choices metas opts r msgs
|
||||
Success r msgs -> backtrack (j+1) xs k input choices metas opts r msgs
|
||||
|
||||
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 input choices metas opts) r msgs ->
|
||||
case Map.lookup c choices of
|
||||
Just j -> case f (xs !! j) of
|
||||
EvalM f -> f g k state r msgs
|
||||
Nothing -> case backtrack g 0 xs choices metas opts [] msgs of
|
||||
Nothing -> case backtrack g 0 xs input choices metas opts [] msgs of
|
||||
Fail msg msgs -> Fail msg msgs
|
||||
Success ts msgs -> k (FV (reverse ts)) state r msgs)
|
||||
where
|
||||
backtrack g j [] choices metas opts ts msgs = Success ts msgs
|
||||
backtrack g j (x:xs) choices metas opts ts msgs =
|
||||
backtrack g j [] input choices metas opts ts msgs = Success ts msgs
|
||||
backtrack g j (x:xs) input choices metas opts ts msgs =
|
||||
case f x 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
|
||||
EvalM f -> case f g (\t st ts msgs -> Success (t:ts) msgs) (State input (Map.insert c j choices) metas opts) ts msgs of
|
||||
Fail msg msgs -> Fail msg msgs
|
||||
Success ts msgs -> backtrack g (j+1) xs choices metas opts ts msgs
|
||||
Success ts msgs -> backtrack g (j+1) xs input choices metas opts ts msgs
|
||||
|
||||
try :: Int -> (a -> EvalM b) -> ([b] -> EvalM b) -> [a] -> EvalM b
|
||||
try sz f select xs = EvalM (\g k state r msgs ->
|
||||
@@ -800,9 +779,9 @@ try sz f select xs = EvalM (\g k state r msgs ->
|
||||
Nothing -> ms
|
||||
|
||||
newResiduation :: Scope -> EvalM MetaId
|
||||
newResiduation scope = EvalM (\g k (State choices metas opts) r msgs ->
|
||||
newResiduation scope = EvalM (\g k (State input choices metas opts) r msgs ->
|
||||
let meta_id = Map.size metas+1
|
||||
in k meta_id (State choices (Map.insert meta_id (Residuation scope) metas) opts) r msgs)
|
||||
in k meta_id (State input choices (Map.insert meta_id (Residuation scope) metas) opts) r msgs)
|
||||
|
||||
checkpoint :: EvalM Int
|
||||
checkpoint = EvalM (\g k state r msgs ->
|
||||
@@ -815,8 +794,8 @@ getMeta i = EvalM (\g k state r msgs ->
|
||||
Nothing -> Fail ("Metavariable ?"<>pp i<+>"is not defined") msgs)
|
||||
|
||||
setMeta :: MetaId -> MetaState -> EvalM ()
|
||||
setMeta i ms = EvalM (\g k (State choices metas opts) r msgs ->
|
||||
let state' = State choices (Map.insert i ms metas) opts
|
||||
setMeta i ms = EvalM (\g k (State input choices metas opts) r msgs ->
|
||||
let state' = State input choices (Map.insert i ms metas) opts
|
||||
in k () state' r msgs)
|
||||
|
||||
value2termM :: Bool -> [Ident] -> Value -> EvalM Term
|
||||
@@ -919,14 +898,20 @@ value2termM flat xs (VGlue v1 v2) = do
|
||||
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)) =
|
||||
EvalM $ \g k (State choices metas opts) r msgs ->
|
||||
let j = fromMaybe 0 (Map.lookup i choices)
|
||||
value2termM False xs (VFV c (VarFree vs)) = variants' c (value2termM False xs) vs
|
||||
value2termM flat xs (VFV c (VarOpts n os)) =
|
||||
EvalM $ \g k (State input choices metas opts) r msgs ->
|
||||
let (j,input',choices',opts') =
|
||||
case Map.lookup c choices of
|
||||
Just j -> (j,input,choices,opts)
|
||||
Nothing -> case input of
|
||||
(c',j):input | c == c' -> let oi = OptionInfo c j n (map fst os)
|
||||
in (j,input,Map.insert c j choices,oi:opts)
|
||||
_ -> let oi = OptionInfo c 0 n (map fst os)
|
||||
in (0,[],Map.insert c 0 choices,oi:opts)
|
||||
in case os `maybeAt` j of
|
||||
Just (l,t) -> case value2termM flat xs t of
|
||||
EvalM f -> let oi = OptionInfo i n (map (\(l,t) -> fromMaybe t l) os)
|
||||
in f g k (State choices metas (oi:opts)) r msgs
|
||||
EvalM f -> f g k (State input' choices' metas 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 (VPattType v) = do t <- value2termM flat xs v
|
||||
@@ -1103,7 +1088,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)
|
||||
where
|
||||
concat v1 (Const (b,ws,qs)) = value2string' g v1 b ws qs
|
||||
concat v1 (CFV i vs) = CFV i (mapConstVs (concat v1) vs)
|
||||
concat v1 (CFV c vs) = CFV c (fmap (concat v1) vs)
|
||||
concat v1 res = res
|
||||
value2string' g (VApp c q []) b ws qs
|
||||
| q == (cPredef,cNonExist) = NonExist
|
||||
@@ -1137,7 +1122,7 @@ value2string' g (VAlts vd vas) b ws qs =
|
||||
| or [startsWith s w | VStr s <- ss] = value2string' g v
|
||||
| otherwise = pre vd vas w
|
||||
value2string' g (VFV s vs) b ws qs =
|
||||
CFV s (variants2consts (\v -> value2string' g v b ws qs) vs)
|
||||
CFV s (fmap (\v -> value2string' g v b ws qs) vs)
|
||||
value2string' _ _ _ _ _ = RunTime
|
||||
|
||||
startsWith [] _ = True
|
||||
@@ -1154,15 +1139,29 @@ string2value' (w:ws) = VC (VStr w) (string2value' ws)
|
||||
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 (VInt n) = Const n
|
||||
value2int g (VFV s vs) = CFV s (variants2consts (value2int g) vs)
|
||||
value2int g (VFV s vs) = CFV s (fmap (value2int g) vs)
|
||||
value2int g _ = RunTime
|
||||
|
||||
value2float g (VMeta i vs) = CSusp i (\v -> value2float g (apply g v vs))
|
||||
value2float g (VSusp i k vs) = CSusp i (\v -> value2float g (apply g (k v) vs))
|
||||
value2float g (VFlt f) = Const f
|
||||
value2float g (VFV s vs) = CFV s (variants2consts (value2float g) vs)
|
||||
value2float g (VFV s vs) = CFV s (fmap (value2float g) vs)
|
||||
value2float g _ = RunTime
|
||||
|
||||
value2expr g xs (VApp _ (m,f) vs)
|
||||
| m /= cPredef = foldl (\e v -> fmap EApp e <*> value2expr g xs v) (pure (EFun (showIdent f))) vs
|
||||
value2expr g xs (VMeta i vs) = CSusp i (\v -> value2expr g xs (apply g v vs))
|
||||
value2expr g xs (VSusp i k vs) = CSusp i (\v -> value2expr g xs (apply g (k v) vs))
|
||||
value2expr g xs (VGen j vs) = foldl (\e v -> fmap EApp e <*> value2expr g xs v) (pure (EVar (length xs - j - 1))) vs
|
||||
value2expr g xs (VClosure env s (Abs b x t)) =
|
||||
let v = eval g ((x,VGen (length xs) []):env) s t []
|
||||
x' = mkFreshVar xs x
|
||||
in fmap (EAbs b (showIdent x')) (value2expr g (x':xs) v)
|
||||
value2expr g xs (VInt n) = pure (ELit (LInt n))
|
||||
value2expr g xs (VFlt f) = pure (ELit (LFlt f))
|
||||
value2expr g xs (VFV s vs) = CFV s (fmap (value2expr g xs) vs)
|
||||
value2expr g xs v = fmap (ELit . LStr) (value2string g v)
|
||||
|
||||
newtype Choice = Choice { unchoice :: Integer }
|
||||
deriving (Eq,Ord,Pretty,Show)
|
||||
|
||||
|
||||
@@ -131,13 +131,22 @@ type2metaTerm gr d ms r rs (RecType lbls) = do
|
||||
type2metaTerm gr d ms r rs (Table p q)
|
||||
| count == 1 = do (ms',r',t) <- type2metaTerm gr d ms r rs q
|
||||
return (ms',r+(r'-r),T (TTyped p) [(PW,t)])
|
||||
| otherwise = do let pv = varX (length rs+1)
|
||||
| null (collectParams q)
|
||||
= do let pv = varX (length rs+1)
|
||||
(ms',delta,t) <-
|
||||
fixST $ \(~(_,delta,_)) ->
|
||||
do (ms',r',t) <- type2metaTerm gr d ms r ((delta,(pv,p)):rs) q
|
||||
return (ms',r'-r,t)
|
||||
return (ms',r+delta*count,T (TTyped p) [(PV pv,t)])
|
||||
| otherwise = do ((ms',r'),ts) <- mapAccumM (\(ms,r) _ -> do (ms',r',t) <- type2metaTerm gr d ms r rs q
|
||||
return ((ms',r'),t))
|
||||
(ms,r) [0..count-1]
|
||||
return (ms',r+(r'-r),V p ts)
|
||||
where
|
||||
collectParams (QC q) = [q]
|
||||
collectParams (Table _ t) = collectParams t
|
||||
collectParams t = collectOp collectParams t
|
||||
|
||||
count = case allParamValues gr p of
|
||||
Ok ts -> length ts
|
||||
Bad msg -> error msg
|
||||
|
||||
@@ -1,313 +0,0 @@
|
||||
{-# LANGUAGE LambdaCase, TupleSections, NamedFieldPuns #-}
|
||||
|
||||
module GF.Compile.Repl (ReplOpts(..), defaultReplOpts, replOptDescrs, getReplOpts, runRepl, runRepl') where
|
||||
|
||||
import Control.Monad (join, when, unless, forM_, foldM)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Char (isSpace)
|
||||
import Data.Function ((&))
|
||||
import Data.Functor ((<&>))
|
||||
import Data.List (find)
|
||||
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.Haskeline (InputT, Settings(..), noCompletion, runInputT, getInputLine, outputStrLn)
|
||||
import System.Directory (getAppUserDataDirectory)
|
||||
|
||||
import GF.Compile (batchCompile)
|
||||
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.TypeCheck.Concrete (inferLType)
|
||||
import GF.Data.ErrM (Err(..))
|
||||
import GF.Data.Utilities (maybeAt, orLeft)
|
||||
import GF.Grammar.Grammar
|
||||
( Grammar
|
||||
, mGrammar
|
||||
, Info
|
||||
, Module
|
||||
, ModuleName
|
||||
, ModuleInfo(..)
|
||||
, ModuleType(MTResource)
|
||||
, ModuleStatus(MSComplete)
|
||||
, OpenSpec(OSimple)
|
||||
, Location (NoLoc)
|
||||
, Term(Typed)
|
||||
, prependModule
|
||||
)
|
||||
import GF.Grammar.Lexer (Posn(..), Lang(..), runLangP)
|
||||
import GF.Grammar.Parser (pTerm)
|
||||
import GF.Grammar.Printer (TermPrintQual(Unqualified), ppTerm)
|
||||
import GF.Infra.CheckM (Check, runCheck)
|
||||
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
|
||||
, noPrelude :: Bool
|
||||
, inputFiles :: [String]
|
||||
, evalToFlat :: Bool
|
||||
}
|
||||
|
||||
defaultReplOpts :: ReplOpts
|
||||
defaultReplOpts = ReplOpts
|
||||
{ lang = GF
|
||||
, noPrelude = False
|
||||
, inputFiles = []
|
||||
, evalToFlat = True
|
||||
}
|
||||
|
||||
type Errs a = Either [String] a
|
||||
type ReplOptsOp = ReplOpts -> Errs ReplOpts
|
||||
|
||||
replOptDescrs :: [OptDescr ReplOptsOp]
|
||||
replOptDescrs =
|
||||
[ Option ['h'] ["help"] (NoArg $ \o -> Left [usageInfo "gfci" replOptDescrs]) "Display help."
|
||||
, Option [] ["no-prelude"] (flag $ \o -> o { noPrelude = True }) "Don't load the prelude."
|
||||
, Option [] ["lang"] (ReqArg (\s o -> case s of
|
||||
"gf" -> Right (o { lang = GF })
|
||||
"bnfc" -> Right (o { lang = BNFC })
|
||||
"nlg" -> Right (o { lang = NLG })
|
||||
_ -> Left ["Unknown language variant: " ++ s])
|
||||
"{gf,bnfc,nlg}")
|
||||
"Set the active language variant."
|
||||
, Option [] ["no-flat"] (flag $ \o -> o { evalToFlat = False }) "Do not evaluate to flat form."
|
||||
]
|
||||
where
|
||||
flag f = NoArg $ \o -> pure (f o)
|
||||
|
||||
getReplOpts :: [String] -> Errs ReplOpts
|
||||
getReplOpts args = case errs of
|
||||
[] -> foldM (&) defaultReplOpts flags <&> \o -> o { inputFiles = inputFiles }
|
||||
_ -> Left errs
|
||||
where
|
||||
(flags, inputFiles, errs) = getOpt RequireOrder replOptDescrs args
|
||||
|
||||
execCheck :: MonadIO m => Check a -> (a -> InputT m b) -> InputT m (Maybe b)
|
||||
execCheck c k = case runCheck c of
|
||||
Ok (a, warn) -> do
|
||||
unless (null warn) $ outputStrLn warn
|
||||
Just <$> k a
|
||||
Bad err -> do
|
||||
outputStrLn err
|
||||
return Nothing
|
||||
|
||||
replModNameStr :: String
|
||||
replModNameStr = "<repl>"
|
||||
|
||||
replModName :: ModuleName
|
||||
replModName = moduleNameS replModNameStr
|
||||
|
||||
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
|
||||
Left (Pn l c, err) -> do
|
||||
outputStrLn $ err ++ " (" ++ show l ++ ":" ++ show c ++ ")"
|
||||
return Nothing
|
||||
Right t -> execCheck (renameSourceTerm g replModName t) $ \t -> k t
|
||||
|
||||
data ResultState = ResultState
|
||||
{ srsResult :: Term
|
||||
, srsChoices :: ChoiceMap
|
||||
, srsOptInfo :: [OptionInfo]
|
||||
, srsOpts :: ChoiceMap
|
||||
}
|
||||
data OptionState = OptionState
|
||||
{ osTerm :: Term
|
||||
, osResults :: [ResultState]
|
||||
, osSelected :: Maybe ResultState
|
||||
}
|
||||
newtype ReplState = ReplState
|
||||
{ rsOpts :: Maybe OptionState
|
||||
}
|
||||
|
||||
initState :: ReplState
|
||||
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) $ \(t, ty) ->
|
||||
let t' = case t of
|
||||
Typed _ _ -> t
|
||||
t -> Typed t ty
|
||||
in outputStrLn $ render (ppTerm Unqualified 0 t')
|
||||
nlrepl st
|
||||
|
||||
-- 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
|
||||
|
||||
-- Select a result to "focus" by its index
|
||||
command st "s" arg = do
|
||||
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))) })
|
||||
|
||||
-- Show the current selected result
|
||||
command st "c" arg = do
|
||||
let e = do (OptionState t _ sel) <- orLeft "No results to select!" $ rsOpts st
|
||||
(ResultState r _ ois os) <- orLeft "No result selected!" sel
|
||||
return (t, r, ois, os)
|
||||
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
|
||||
(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 opts@ReplOpts { noPrelude, inputFiles } = do
|
||||
-- TODO accept an ngf grammar
|
||||
let toLoad = if noPrelude then inputFiles else "prelude/Predef.gfo" : inputFiles
|
||||
(g0, opens) <- case toLoad of
|
||||
[] -> pure (mGrammar [], [])
|
||||
_ -> do
|
||||
(_, g0) <- batchCompile noOptions Nothing toLoad
|
||||
pure (g0, OSimple . moduleNameS . justModuleName <$> toLoad)
|
||||
let
|
||||
modInfo = ModInfo
|
||||
{ mtype = MTResource
|
||||
, mstatus = MSComplete
|
||||
, mflags = noOptions
|
||||
, mextend = []
|
||||
, mwith = Nothing
|
||||
, mopens = opens
|
||||
, mexdeps = []
|
||||
, msrc = replModNameStr
|
||||
, mseqs = Nothing
|
||||
, jments = Map.empty
|
||||
}
|
||||
g = Gl (prependModule g0 (replModName, modInfo)) (if noPrelude then Map.empty else stdPredef g)
|
||||
runRepl' opts g
|
||||
@@ -1,11 +1,13 @@
|
||||
----------------------------------------------------------------------
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : XML
|
||||
--
|
||||
-- Utilities for creating XML documents.
|
||||
----------------------------------------------------------------------
|
||||
module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where
|
||||
module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML, parseXML) where
|
||||
|
||||
import Data.Char(isSpace)
|
||||
import Numeric (readHex)
|
||||
import GF.Data.Utilities
|
||||
|
||||
data XML = Data String | Tag String [Attr] [XML] | ETag String [Attr] | Comment String | Empty
|
||||
@@ -54,3 +56,229 @@ escape = concatMap escChar
|
||||
bottomUpXML :: (XML -> XML) -> XML -> XML
|
||||
bottomUpXML f (Tag n attrs cs) = f (Tag n attrs (map (bottomUpXML f) cs))
|
||||
bottomUpXML f x = f x
|
||||
|
||||
|
||||
-- Lexer -----------------------------------------------------------------------
|
||||
|
||||
type Line = Integer
|
||||
type LChar = (Line,Char)
|
||||
type LString = [LChar]
|
||||
data Token = TokStart Line String [Attr] Bool -- is empty?
|
||||
| TokEnd Line String
|
||||
| TokCRef String
|
||||
| TokText String
|
||||
deriving Show
|
||||
|
||||
tokens :: String -> [Token]
|
||||
tokens = tokens' . linenumber 1
|
||||
|
||||
tokens' :: LString -> [Token]
|
||||
tokens' ((_,'<') : c@(_,'!') : cs) = special c cs
|
||||
|
||||
tokens' ((_,'<') : cs) = tag (dropSpace cs) -- we are being nice here
|
||||
tokens' [] = []
|
||||
tokens' cs@((l,_):_) = let (as,bs) = breakn ('<' ==) cs
|
||||
in map cvt (decode_text as) ++ tokens' bs
|
||||
|
||||
-- XXX: Note, some of the lines might be a bit inacuarate
|
||||
where cvt (TxtBit x) = TokText x
|
||||
cvt (CRefBit x) = case cref_to_char x of
|
||||
Just c -> TokText [c]
|
||||
Nothing -> TokCRef x
|
||||
|
||||
|
||||
special :: LChar -> LString -> [Token]
|
||||
special _ ((_,'-') : (_,'-') : cs) = skip cs
|
||||
where skip ((_,'-') : (_,'-') : (_,'>') : ds) = tokens' ds
|
||||
skip (_ : ds) = skip ds
|
||||
skip [] = [] -- unterminated comment
|
||||
|
||||
special c ((_,'[') : (_,'C') : (_,'D') : (_,'A') : (_,'T') : (_,'A') : (_,'[')
|
||||
: cs) =
|
||||
let (xs,ts) = cdata cs
|
||||
in TokText xs : tokens' ts
|
||||
where cdata ((_,']') : (_,']') : (_,'>') : ds) = ([],ds)
|
||||
cdata ((_,d) : ds) = let (xs,ys) = cdata ds in (d:xs,ys)
|
||||
cdata [] = ([],[])
|
||||
|
||||
special c cs =
|
||||
let (xs,ts) = munch "" 0 cs
|
||||
in TokText ('<':'!':(reverse xs)) : tokens' ts
|
||||
where munch acc nesting ((_,'>') : ds)
|
||||
| nesting == (0::Int) = ('>':acc,ds)
|
||||
| otherwise = munch ('>':acc) (nesting-1) ds
|
||||
munch acc nesting ((_,'<') : ds)
|
||||
= munch ('<':acc) (nesting+1) ds
|
||||
munch acc n ((_,x) : ds) = munch (x:acc) n ds
|
||||
munch acc _ [] = (acc,[]) -- unterminated DTD markup
|
||||
|
||||
--special c cs = tag (c : cs) -- invalid specials are processed as tags
|
||||
|
||||
linenumber :: Integer -> String -> LString
|
||||
linenumber n s =
|
||||
case s of
|
||||
[] -> []
|
||||
('\r':s') -> case s' of
|
||||
('\n':s'') -> next s''
|
||||
_ -> next s'
|
||||
('\n':s') -> next s'
|
||||
(c :s') -> (n,c) : linenumber n s'
|
||||
where
|
||||
next s' = n' `seq` ((n,'\n'):linenumber n' s') where n' = n + 1
|
||||
|
||||
|
||||
qualName :: LString -> (String,LString)
|
||||
qualName xs = breakn endName xs
|
||||
where endName x = isSpace x || x == '=' || x == '>' || x == '/'
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
tag :: LString -> [Token]
|
||||
tag ((p,'/') : cs) = let (n,ds) = qualName (dropSpace cs)
|
||||
in TokEnd p n : case (dropSpace ds) of
|
||||
(_,'>') : es -> tokens' es
|
||||
-- tag was not properly closed...
|
||||
_ -> tokens' ds
|
||||
tag [] = []
|
||||
tag cs = let (n,ds) = qualName cs
|
||||
(as,b,ts) = attribs (dropSpace ds)
|
||||
in TokStart (fst (head cs)) n as b : ts
|
||||
|
||||
attribs :: LString -> ([Attr], Bool, [Token])
|
||||
attribs cs = case cs of
|
||||
(_,'>') : ds -> ([], False, tokens' ds)
|
||||
|
||||
(_,'/') : ds -> ([], True, case ds of
|
||||
(_,'>') : es -> tokens' es
|
||||
-- insert missing > ...
|
||||
_ -> tokens' ds)
|
||||
|
||||
(_,'?') : (_,'>') : ds -> ([], True, tokens' ds)
|
||||
|
||||
-- doc ended within a tag..
|
||||
[] -> ([],False,[])
|
||||
|
||||
_ -> let (a,cs1) = attrib cs
|
||||
(as,b,ts) = attribs cs1
|
||||
in (a:as,b,ts)
|
||||
|
||||
attrib :: LString -> (Attr,LString)
|
||||
attrib cs = let (ks,cs1) = qualName cs
|
||||
(vs,cs2) = attr_val (dropSpace cs1)
|
||||
in ((ks,decode_attr vs),dropSpace cs2)
|
||||
|
||||
attr_val :: LString -> (String,LString)
|
||||
attr_val ((_,'=') : cs) = string (dropSpace cs)
|
||||
attr_val cs = ("",cs)
|
||||
|
||||
|
||||
dropSpace :: LString -> LString
|
||||
dropSpace = dropWhile (isSpace . snd)
|
||||
|
||||
-- | Match the value for an attribute. For malformed XML we do
|
||||
-- our best to guess the programmer's intention.
|
||||
string :: LString -> (String,LString)
|
||||
string ((_,'"') : cs) = break' ('"' ==) cs
|
||||
|
||||
-- Allow attributes to be enclosed between ' '.
|
||||
string ((_,'\'') : cs) = break' ('\'' ==) cs
|
||||
|
||||
-- Allow attributes that are not enclosed by anything.
|
||||
string cs = breakn eos cs
|
||||
where eos x = isSpace x || x == '>' || x == '/'
|
||||
|
||||
|
||||
break' :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)])
|
||||
break' p xs = let (as,bs) = breakn p xs
|
||||
in (as, case bs of
|
||||
[] -> []
|
||||
_ : cs -> cs)
|
||||
|
||||
breakn :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)])
|
||||
breakn p l = (map snd as,bs) where (as,bs) = break (p . snd) l
|
||||
|
||||
|
||||
|
||||
decode_attr :: String -> String
|
||||
decode_attr cs = concatMap cvt (decode_text cs)
|
||||
where cvt (TxtBit x) = x
|
||||
cvt (CRefBit x) = case cref_to_char x of
|
||||
Just c -> [c]
|
||||
Nothing -> '&' : x ++ ";"
|
||||
|
||||
data Txt = TxtBit String | CRefBit String deriving Show
|
||||
|
||||
decode_text :: [Char] -> [Txt]
|
||||
decode_text xs@('&' : cs) = case break (';' ==) cs of
|
||||
(as,_:bs) -> CRefBit as : decode_text bs
|
||||
_ -> [TxtBit xs]
|
||||
decode_text [] = []
|
||||
decode_text cs = let (as,bs) = break ('&' ==) cs
|
||||
in TxtBit as : decode_text bs
|
||||
|
||||
cref_to_char :: [Char] -> Maybe Char
|
||||
cref_to_char cs = case cs of
|
||||
'#' : ds -> num_esc ds
|
||||
"lt" -> Just '<'
|
||||
"gt" -> Just '>'
|
||||
"amp" -> Just '&'
|
||||
"apos" -> Just '\''
|
||||
"quot" -> Just '"'
|
||||
_ -> Nothing
|
||||
|
||||
num_esc :: String -> Maybe Char
|
||||
num_esc cs = case cs of
|
||||
'x' : ds -> check (readHex ds)
|
||||
_ -> check (reads cs)
|
||||
|
||||
where check [(n,"")] = cvt_char n
|
||||
check _ = Nothing
|
||||
|
||||
cvt_char :: Int -> Maybe Char
|
||||
cvt_char x
|
||||
| fromEnum (minBound :: Char) <= x && x <= fromEnum (maxBound::Char)
|
||||
= Just (toEnum x)
|
||||
| otherwise = Nothing
|
||||
|
||||
|
||||
-- Parser --------------------------------------------------------------
|
||||
|
||||
-- | parseXML to a list of content chunks
|
||||
parseXML :: String -> [XML]
|
||||
parseXML = parse . tokens
|
||||
|
||||
------------------------------------------------------------------------
|
||||
|
||||
parse :: [Token] -> [XML]
|
||||
parse [] = []
|
||||
parse ts = let (es,_,ts1) = nodes [] ts
|
||||
in es ++ parse ts1
|
||||
|
||||
nodes :: [String] -> [Token] -> ([XML], [String], [Token])
|
||||
nodes ps (TokCRef ref : ts) =
|
||||
let (es,qs,ts1) = nodes ps ts
|
||||
in (Data ref : es, qs, ts1)
|
||||
nodes ps (TokText txt : ts) =
|
||||
let (es,qs,ts1) = nodes ps ts
|
||||
(more,es1) = case es of
|
||||
Data cd : es1' -> (cd,es1')
|
||||
_ -> ([],es)
|
||||
in (Data (txt ++ more) : es1, qs, ts1)
|
||||
nodes ps (TokStart p t as empty : ts) = (node : siblings, open, toks)
|
||||
where
|
||||
(node,(siblings,open,toks))
|
||||
| empty = (ETag t as, nodes ps ts)
|
||||
| otherwise = let (es1,qs1,ts1) = nodes (t:ps) ts
|
||||
in (Tag t as es1,
|
||||
case qs1 of
|
||||
[] -> nodes ps ts1
|
||||
_ : qs3 -> ([],qs3,ts1))
|
||||
nodes ps (TokEnd p t : ts) = case break (t ==) ps of
|
||||
(as,_:_) -> ([],as,ts)
|
||||
-- Unknown closing tag. Insert as text.
|
||||
(_,[]) ->
|
||||
let (es,qs,ts1) = nodes ps ts
|
||||
in (Data "" : es,qs,ts1)
|
||||
nodes ps [] = ([],ps,[])
|
||||
|
||||
@@ -394,8 +394,6 @@ data Term =
|
||||
| ELincat Ident Term -- ^ boxed linearization type of Ident
|
||||
| ELin Ident Term -- ^ boxed linearization of type Ident
|
||||
|
||||
| AdHocOverload [Term] -- ^ ad hoc overloading generated in Rename
|
||||
|
||||
| FV [Term] -- ^ alternatives in free variation: @variants { s ; ... }@
|
||||
|
||||
| Markup Ident [(Ident,Term)] [Term]
|
||||
|
||||
@@ -123,7 +123,6 @@ term2json (Glue t1 t2) = makeObj [("glue1",term2json t1),("glue2", term2json t2)
|
||||
term2json (EPattType t) = makeObj [("patttype",term2json t)]
|
||||
term2json (ELincat id t) = makeObj [("lincat",showJSON id), ("term",term2json t)]
|
||||
term2json (ELin id t) = makeObj [("lin",showJSON id), ("term",term2json t)]
|
||||
term2json (AdHocOverload ts) = makeObj [("overloaded",showJSON (map term2json ts))]
|
||||
term2json (FV ts) = makeObj [("variants",showJSON (map term2json ts))]
|
||||
term2json (Markup tag attrs children) = makeObj [ ("tag",showJSON tag)
|
||||
, ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json val)) attrs))
|
||||
@@ -175,7 +174,6 @@ json2term o = Vr <$> o!:"vr"
|
||||
<|> EPattType <$> o!<"patttype"
|
||||
<|> ELincat <$> o!:"lincat" <*> o!<"term"
|
||||
<|> ELin <$> o!:"lin" <*> o!<"term"
|
||||
<|> AdHocOverload <$> (o!:"overloaded" >>= mapM json2term)
|
||||
<|> FV <$> (o!:"variants" >>= mapM json2term)
|
||||
<|> Markup <$> (o!:"tag") <*>
|
||||
(o!:"attrs" >>= mapM (\(attr,val) -> fmap ((,)attr) (json2term val))) <*>
|
||||
|
||||
@@ -68,7 +68,11 @@ lookupIdentInfo (m,ModPGF{mpgf=pgf}) i =
|
||||
Nothing -> notFound i
|
||||
where
|
||||
cnvType xs (PGF2.DTyp hypos cat es) =
|
||||
appHypos hypos xs (QC (m,identS cat)) es
|
||||
let t | cat == "String" = Sort cStr
|
||||
| cat == "Int" = QC (cPredef,cInt)
|
||||
| cat == "Float" = QC (cPredef,cFloat)
|
||||
| otherwise = QC (m,identS cat)
|
||||
in appHypos hypos xs t es
|
||||
|
||||
appHypos [] xs t es =
|
||||
foldl (appExpr xs) t es
|
||||
|
||||
@@ -466,7 +466,6 @@ collectOp co trm = case trm of
|
||||
Strs tt -> mconcatMap co tt
|
||||
ELincat _ t -> co t
|
||||
ELin _ t -> co t
|
||||
AdHocOverload ts -> mconcatMap co ts
|
||||
Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap co cs
|
||||
Reset _ ct t _-> maybe mempty co ct <> co t
|
||||
_ -> mempty -- covers K, Vr, Cn, Sort
|
||||
|
||||
@@ -720,7 +720,7 @@ NLG :: { Map.Map Ident Info }
|
||||
|
||||
ListNLGDef :: { [(Ident,Info)] }
|
||||
ListNLGDef
|
||||
: 'oper' NLGDef { [] }
|
||||
: 'oper' NLGDef { $2 }
|
||||
| 'oper' NLGDef ListNLGDef { $2 ++ $3 }
|
||||
|
||||
NLGDef :: { [(Ident,Info)] }
|
||||
|
||||
@@ -1,183 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : PatternMatch
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/12 12:38:29 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.7 $
|
||||
--
|
||||
-- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.PatternMatch (
|
||||
matchPattern,
|
||||
testOvershadow,
|
||||
findMatch
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Macros
|
||||
--import GF.Grammar.Printer
|
||||
|
||||
import Data.Maybe(fromMaybe)
|
||||
import Control.Monad
|
||||
import GF.Text.Pretty
|
||||
--import Debug.Trace
|
||||
|
||||
matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
|
||||
matchPattern pts term =
|
||||
if not (isInConstantForm term)
|
||||
then raise (render ("variables occur in" <+> pp term))
|
||||
else do
|
||||
term' <- mkK term
|
||||
errIn (render ("trying patterns" <+> hsep (punctuate ',' (map fst pts)))) $
|
||||
findMatch [([p],t) | (p,t) <- pts] [term']
|
||||
where
|
||||
-- to capture all Str with string pattern matching
|
||||
mkK s = case s of
|
||||
C _ _ -> do
|
||||
s' <- getS s
|
||||
return (K (unwords s'))
|
||||
_ -> return s
|
||||
|
||||
getS s = case s of
|
||||
K w -> return [w]
|
||||
C v w -> liftM2 (++) (getS v) (getS w)
|
||||
Empty -> return []
|
||||
_ -> raise (render ("cannot get string from" <+> s))
|
||||
|
||||
testOvershadow :: ErrorMonad m => [Patt] -> [Term] -> m [Patt]
|
||||
testOvershadow pts vs = do
|
||||
let numpts = zip pts [0..]
|
||||
let cases = [(p,EInt i) | (p,i) <- numpts]
|
||||
ts <- mapM (liftM fst . matchPattern cases) vs
|
||||
return [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ]
|
||||
|
||||
findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
|
||||
findMatch cases terms = case cases of
|
||||
[] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms)))
|
||||
(patts,_):_ | length patts /= length terms ->
|
||||
raise (render ("wrong number of args for patterns :" <+> hsep patts <+>
|
||||
"cannot take" <+> hsep terms))
|
||||
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
|
||||
Ok substs -> return (val, concat substs)
|
||||
_ -> findMatch cc terms
|
||||
|
||||
tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
|
||||
tryMatch (p,t) = do
|
||||
t' <- termForm t
|
||||
trym p t'
|
||||
where
|
||||
trym p t' =
|
||||
case (p,t') of
|
||||
-- (_,(x,Typed e ty,y)) -> trym p (x,e,y) -- Add this? /TH 2013-09-05
|
||||
(_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = []
|
||||
(PW, _) -> return [] -- optimization with wildcard
|
||||
(PV x,([],K s,[])) -> return [(x,words2term (words s))]
|
||||
(PV x, _) -> return [(x,t)]
|
||||
(PString s, ([],K i,[])) | s==i -> return []
|
||||
(PInt s, ([],EInt i,[])) | s==i -> return []
|
||||
(PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
|
||||
(PC p pp, ([], Con f, tt)) |
|
||||
p `eqStrIdent` f && length pp == length tt ->
|
||||
do matches <- mapM tryMatch (zip pp tt)
|
||||
return (concat matches)
|
||||
|
||||
(PP (q,p) pp, ([], QC (r,f), tt)) |
|
||||
-- q `eqStrIdent` r && --- not for inherited AR 10/10/2005
|
||||
p `eqStrIdent` f && length pp == length tt ->
|
||||
do matches <- mapM tryMatch (zip pp tt)
|
||||
return (concat matches)
|
||||
---- hack for AppPredef bug
|
||||
(PP (q,p) pp, ([], Q (r,f), tt)) |
|
||||
-- q `eqStrIdent` r && ---
|
||||
p `eqStrIdent` f && length pp == length tt ->
|
||||
do matches <- mapM tryMatch (zip pp tt)
|
||||
return (concat matches)
|
||||
|
||||
(PR r, ([],R r',[])) |
|
||||
all (`elem` map fst r') (map fst r) ->
|
||||
do matches <- mapM tryMatch
|
||||
[(p,snd a) | (l,p) <- r, let Just a = lookup l r']
|
||||
return (concat matches)
|
||||
(PT _ p',_) -> trym p' t'
|
||||
|
||||
(PAs x p',([],K s,[])) -> do
|
||||
subst <- trym p' t'
|
||||
return $ (x,words2term (words s)) : subst
|
||||
|
||||
(PAs x p',_) -> do
|
||||
subst <- trym p' t'
|
||||
return $ (x,t) : subst
|
||||
|
||||
(PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t']
|
||||
|
||||
(PNeg p',_) -> case tryMatch (p',t) of
|
||||
Bad _ -> return []
|
||||
_ -> raise (render ("no match with negative pattern" <+> p))
|
||||
|
||||
(PSeq min1 max1 p1 min2 max2 p2, ([],K s, [])) -> matchPSeq min1 max1 p1 min2 max2 p2 s
|
||||
|
||||
(PRep _ _ p1, ([],K s, [])) -> checks [
|
||||
trym (foldr (const (PSeq 0 Nothing p1 0 Nothing)) (PString "")
|
||||
[1..n]) t' | n <- [0 .. length s]
|
||||
] >>
|
||||
return []
|
||||
|
||||
(PChar, ([],K [_], [])) -> return []
|
||||
(PChars cs, ([],K [c], [])) | elem c cs -> return []
|
||||
|
||||
_ -> raise (render ("no match in case expr for" <+> t))
|
||||
|
||||
words2term [] = Empty
|
||||
words2term [w] = K w
|
||||
words2term (w:ws) = C (K w) (words2term ws)
|
||||
|
||||
matchPSeq min1 max1 p1 min2 max2 p2 s =
|
||||
do let n = length s
|
||||
lo = min1 `max` (n-fromMaybe n max2)
|
||||
hi = (n-min2) `min` (fromMaybe n max1)
|
||||
cuts = [splitAt i s | i <- [lo..hi]]
|
||||
matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
|
||||
return (concat matches)
|
||||
|
||||
isInConstantForm :: Term -> Bool
|
||||
isInConstantForm trm = case trm of
|
||||
Cn _ -> True
|
||||
Con _ -> True
|
||||
Q _ -> True
|
||||
QC _ -> True
|
||||
Abs _ _ _ -> True
|
||||
C c a -> isInConstantForm c && isInConstantForm a
|
||||
App c a -> isInConstantForm c && isInConstantForm a
|
||||
R r -> all (isInConstantForm . snd . snd) r
|
||||
K _ -> True
|
||||
Empty -> True
|
||||
EInt _ -> True
|
||||
V ty ts -> isInConstantForm ty && all isInConstantForm ts -- TH 2013-09-05
|
||||
-- Typed e t-> isInConstantForm e && isInConstantForm t -- Add this? TH 2013-09-05
|
||||
|
||||
_ -> False ---- isInArgVarForm trm
|
||||
{- -- unused and suspicuous, see contP in GF.Compile.Compute.Concrete instead
|
||||
varsOfPatt :: Patt -> [Ident]
|
||||
varsOfPatt p = case p of
|
||||
PV x -> [x]
|
||||
PC _ ps -> concat $ map varsOfPatt ps
|
||||
PP _ ps -> concat $ map varsOfPatt ps
|
||||
PR r -> concat $ map (varsOfPatt . snd) r
|
||||
PT _ q -> varsOfPatt q
|
||||
_ -> []
|
||||
|
||||
-- | to search matching parameter combinations in tables
|
||||
isMatchingForms :: [Patt] -> [Term] -> Bool
|
||||
isMatchingForms ps ts = all match (zip ps ts') where
|
||||
match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds
|
||||
match _ = True
|
||||
ts' = map appForm ts
|
||||
|
||||
-}
|
||||
@@ -224,7 +224,6 @@ ppTerm q d (Opts t opts) = "option" <+> ppTerm q 0 t <+>"of" <+> '{' $$
|
||||
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 (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))))
|
||||
ppTerm q d (Strs es) = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
|
||||
ppTerm q d (EPatt _ _ p)=prec d 4 ('#' <+> ppPatt q 2 p)
|
||||
|
||||
@@ -1,12 +0,0 @@
|
||||
import GHC.IO.Encoding (setLocaleEncoding, utf8)
|
||||
|
||||
import System.Environment (getArgs)
|
||||
import GF.Compile.Repl (getReplOpts, runRepl)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
setLocaleEncoding utf8
|
||||
args <- getArgs
|
||||
case getReplOpts args of
|
||||
Left errs -> mapM_ putStrLn errs
|
||||
Right opts -> runRepl opts
|
||||
@@ -121,7 +121,6 @@ library
|
||||
GF.Compile.GrammarToCanonical
|
||||
GF.Compile.ReadFiles
|
||||
GF.Compile.Rename
|
||||
GF.Compile.Repl
|
||||
GF.Compile.SubExOpt
|
||||
GF.Compile.Tags
|
||||
GF.Compile.ToAPI
|
||||
@@ -147,7 +146,6 @@ library
|
||||
GF.Grammar.Lookup
|
||||
GF.Grammar.Macros
|
||||
GF.Grammar.Parser
|
||||
GF.Grammar.PatternMatch
|
||||
GF.Grammar.Predef
|
||||
GF.Grammar.Printer
|
||||
GF.Grammar.ShowTerm
|
||||
@@ -239,12 +237,6 @@ executable gf
|
||||
build-depends: base >= 4.6 && <5, directory>=1.2, gf
|
||||
ghc-options: -threaded
|
||||
|
||||
executable gfci
|
||||
main-is: gf-repl.hs
|
||||
default-language: Haskell2010
|
||||
build-depends: base >= 4.6 && < 5, gf
|
||||
ghc-options: -threaded
|
||||
|
||||
test-suite gf-tests
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: run.hs
|
||||
|
||||
@@ -859,8 +859,8 @@ _collect_cats(PgfItor *fn, PgfText *key, object value, PgfExn *err)
|
||||
|
||||
if (PyList_Append((PyObject*) clo->collection, py_name) != 0) {
|
||||
err->type = PGF_EXN_OTHER_ERROR;
|
||||
Py_DECREF(py_name);
|
||||
}
|
||||
Py_DECREF(py_name);
|
||||
}
|
||||
|
||||
static PyObject *
|
||||
|
||||
Reference in New Issue
Block a user