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

merge

Browse Source
This commit is contained in:
Krasimir Angelov
2025-09-17 10:17:37 +02:00
parent 09e98ed323
commit 72028c7ae7
22 changed files with 2178 additions and 2840 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
src/compiler/api/GF/Command/SourceCommands.hs
View File

@@ -20,7 +20,7 @@ import GF.Grammar.ShowTerm
import GF.Grammar.Lookup (allOpers,allOpersTo)
import GF.Compile.Rename(renameSourceTerm)
import GF.Compile.Compute.Concrete2(normalForm,normalFlatForm,Globals(..),stdPredef)
import GF.Compile.TypeCheck.ConcreteNew as TC(inferLType)
import GF.Compile.TypeCheck.Concrete as TC(inferLType)
import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
import GF.Command.CommandInfo
@@ -245,10 +245,10 @@ checkComputeTerm os sgr t =
Nothing -> checkError (pp "No source grammar in scope")
Just mo -> return mo
t <- renameSourceTerm sgr mo t
ttys <- inferLType g t
(t,_) <- inferLType g t
if isOpt "flat" os
then fmap concat (mapM (\(t,_) -> fmap (map evalStr) (normalFlatForm g t)) ttys)
else fmap concat (mapM (\(t,_) -> fmap (singleton . evalStr) (normalForm g t)) ttys)
then fmap (map evalStr) (normalFlatForm g t)
else fmap (singleton . evalStr) (normalForm g t)
where
-- ** Try to compute pre{...} tokens in token sequences
singleton x = [x]

45
src/compiler/api/GF/Compile/CheckGrammar.hs
View File

@@ -27,9 +27,8 @@ import GF.Infra.Ident
import GF.Infra.Option
import GF.Compile.TypeCheck.Abstract
import GF.Compile.TypeCheck.Concrete(checkLType,inferLType,ppType)
import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef)
import GF.Compile.TypeCheck.Concrete(checkLType,inferLType)
import GF.Compile.Compute.Concrete2(normalForm,Globals(..),stdPredef)
import GF.Grammar
import GF.Grammar.Lexer
@@ -173,26 +172,26 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
CncCat mty mdef mref mpr mpmcfg -> do
mty <- case mty of
Just (L loc typ) -> chIn loc "linearization type of" $ do
(typ,_) <- checkLType gr [] typ typeType
typ <- normalForm (Gl gr stdPredef) typ
(typ,_) <- checkLType g typ typeType
typ <- normalForm g typ
return (Just (L loc typ))
Nothing -> return Nothing
mdef <- case (mty,mdef) of
(Just (L _ typ),Just (L loc def)) ->
chIn loc "default linearization of" $ do
(def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
(def,_) <- checkLType g def (mkFunType [typeStr] typ)
return (Just (L loc def))
_ -> return Nothing
mref <- case (mty,mref) of
(Just (L _ typ),Just (L loc ref)) ->
chIn loc "reference linearization of" $ do
(ref,_) <- checkLType gr [] ref (mkFunType [typ] typeStr)
(ref,_) <- checkLType g ref (mkFunType [typ] typeStr)
return (Just (L loc ref))
_ -> return Nothing
mpr <- case mpr of
(Just (L loc t)) ->
chIn loc "print name of" $ do
(t,_) <- checkLType gr [] t typeStr
(t,_) <- checkLType g t typeStr
return (Just (L loc t))
_ -> return Nothing
update sm c (CncCat mty mdef mref mpr mpmcfg)
@@ -201,13 +200,13 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
mt <- case (mty,mt) of
(Just (_,cat,cont,val),Just (L loc trm)) ->
chIn loc "linearization of" $ do
(trm,_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars
(trm,_) <- checkLType g trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars
return (Just (L loc (etaExpand [] trm cont)))
_ -> return mt
mpr <- case mpr of
(Just (L loc t)) ->
chIn loc "print name of" $ do
(t,_) <- checkLType gr [] t typeStr
(t,_) <- checkLType g t typeStr
return (Just (L loc t))
_ -> return Nothing
update sm c (CncFun mty mt mpr mpmcfg)
@@ -216,14 +215,14 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
(pty', pde') <- case (pty,pde) of
(Just (L loct ty), Just (L locd de)) -> do
ty' <- chIn loct "operation" $ do
(ty,_) <- checkLType gr [] ty typeType
normalForm (Gl gr stdPredef) ty
(ty,_) <- checkLType g ty typeType
normalForm g ty
(de',_) <- chIn locd "operation" $
checkLType gr [] de ty'
checkLType g de ty'
return (Just (L loct ty'), Just (L locd de'))
(Nothing , Just (L locd de)) -> do
(de',ty') <- chIn locd "operation" $
inferLType gr [] de
inferLType g de
return (Just (L locd ty'), Just (L locd de'))
(Just (L loct ty), Nothing) -> do
chIn loct "operation" $
@@ -231,14 +230,14 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
update sm c (ResOper pty' pde')
ResOverload os tysts -> chIn NoLoc "overloading" $ do
tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones
tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType g t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones
tysts0 <- lookupOverload gr (fst sm,c) -- check against inherited ones too
tysts1 <- mapM (uncurry $ flip (checkLType gr []))
[(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
tysts1 <- sequence
[checkLType g tr (mkFunType args val) | (args,(val,tr)) <- tysts0]
--- this can only be a partial guarantee, since matching
--- with value type is only possible if expected type is given
checkUniq $
sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
--checkUniq $
-- sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
update sm c (ResOverload os [(y,x) | (x,y) <- tysts'])
ResParam (Just (L loc pcs)) _ -> do
@@ -249,11 +248,12 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
_ -> return sm
where
gr = prependModule sgr sm
g = Gl gr (stdPredef g)
chIn loc cat = checkInModule cwd (snd sm) loc ("Happened in" <+> cat <+> c)
mkParamValues sm c cnt ts [] = return (sm,cnt,[],[])
mkParamValues sm@(mn,mi) c cnt ts ((p,co):pcs) = do
co <- mapM (\(b,v,ty) -> normalForm (Gl gr stdPredef) ty >>= \ty -> return (b,v,ty)) co
co <- mapM (\(b,v,ty) -> normalForm g ty >>= \ty -> return (b,v,ty)) co
sm <- case lookupIdent p (jments mi) of
Ok (ResValue (L loc _) _) -> update sm p (ResValue (L loc (mkProdSimple co (QC (mn,c)))) cnt)
Bad msg -> checkError (pp msg)
@@ -264,7 +264,7 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
checkUniq xss = case xss of
x:y:xs
| x == y -> checkError $ "ambiguous for type" <+>
ppType (mkFunType (tail x) (head x))
ppTerm Terse 0 (mkFunType (tail x) (head x))
| otherwise -> checkUniq $ y:xs
_ -> return ()
@@ -327,6 +327,7 @@ linTypeOfType cnc m (L loc typ) = do
plusRecType vars val
return ((Explicit,varX i,rec),cat)
lookLin (_,c) = checks [ --- rather: update with defLinType ?
lookupLincat cnc m c >>= normalForm (Gl cnc stdPredef)
lookupLincat cnc m c >>= normalForm g
,return defLinType
]
g = Gl cnc (stdPredef g)

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

@@ -1,18 +1,16 @@
{-# LANGUAGE RankNTypes, BangPatterns, GeneralizedNewtypeDeriving, TupleSections #-}
module GF.Compile.Compute.Concrete2
(Env, Scope, Value(..), Variants(..), Constraint, OptionInfo(..), ChoiceMap, cleanOptions,
ConstValue(..), ConstVariants(..), Globals(..), PredefTable, EvalM,
mapVariants, mapVariantsC, unvariants, variants2consts,
mapConstVs, mapConstVsC, unconstVs, consts2variants,
runEvalM, runEvalMWithOpts, reset, reset1, stdPredef, globals, withState,
(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, bubble, patternMatch, vtableSelect, State(..),
newResiduation, getMeta, setMeta, MetaState(..), variants, try,
evalError, evalWarn, ppValue, Choice(..), unit, poison, split, split3, split4,
mapC, forC, mapCM, forCM) where
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
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import GF.Infra.Ident
@@ -26,6 +24,7 @@ import GF.Grammar.Predef
import GF.Grammar.Printer hiding (ppValue)
import GF.Grammar.Lockfield(lockLabel)
import GF.Text.Pretty hiding (empty)
import qualified GF.Text.Pretty as PP
import Control.Monad
import Control.Applicative hiding (Const)
import qualified Control.Applicative as A
@@ -35,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 }
@@ -67,7 +67,7 @@ data Value
| VGen {-# UNPACK #-} !Int [Value]
| VClosure Env Choice Term
| VProd BindType Ident Value Value
| VRecType [(Label, Value)]
| VRecType [(Label, Bool, Value)] Bool
| VR [(Label, Value)]
| VP Value Label [Value]
| VExtR Value Value
@@ -84,40 +84,35 @@ 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]
| VReset Ident (Maybe Value) Value QIdent
| VReset Ident (Maybe Value) Value (Maybe QIdent)
| VSymCat Int LIndex [(LIndex, (Value, Type))]
| VError Doc
-- These two constructors are only used internally
-- in the type checker.
| VCRecType [(Label, Bool, Value)]
| VCInts (Maybe Integer) (Maybe Integer)
| VInts Integer Bool
third f (a,b,c) = (a, b, f c)
data Variants a
= VarFree [a]
| VarOpts Value [(Value, a)]
data Variants
= VarFree [Value]
| VarOpts Value Value [(Value, Value, Value)]
instance Functor Variants where
fmap f (VarFree vs) = VarFree (f <$> vs)
fmap f (VarOpts n cs) = VarOpts n (second f <$> cs)
mapVariants :: (Value -> Value) -> Variants -> Variants
mapVariants f (VarFree vs) = VarFree (f <$> vs)
mapVariants f (VarOpts nty n cs) = VarOpts nty n (third f <$> cs)
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)
mapVariantsC :: (Choice -> Value -> Value) -> Choice -> Variants -> Variants
mapVariantsC f c (VarFree vs) = VarFree (mapC f c vs)
mapVariantsC f c (VarOpts nty n cs) = VarOpts nty n (mapC (third . f) c cs)
unvariants :: Variants -> [Value]
unvariants (VarFree vs) = vs
unvariants (VarOpts nty n cs) = cs <&> \(_,_,v) -> v
unvariants :: Variants a -> [a]
unvariants (VarFree vs) = vs
unvariants (VarOpts n cs) = snd <$> cs
isCanonicalForm :: Bool -> Value -> Bool
isCanonicalForm flat (VClosure {}) = True
isCanonicalForm flat (VProd b x d cod) = isCanonicalForm flat d && isCanonicalForm flat cod
isCanonicalForm flat (VRecType fs) = all (isCanonicalForm flat . snd) fs
isCanonicalForm flat (VRecType fs _) = all (\(l,_,ty) -> isCanonicalForm flat ty) fs
isCanonicalForm flat (VR {}) = True
isCanonicalForm flat (VTable d cod) = isCanonicalForm flat d && isCanonicalForm flat cod
isCanonicalForm flat (VT {}) = True
@@ -138,29 +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 Value [(Value, Value, ConstValue a)]
mapConstVs :: (ConstValue a -> ConstValue b) -> ConstVariants a -> ConstVariants b
mapConstVs f (ConstFree vs) = ConstFree (f <$> vs)
mapConstVs f (ConstOpts nty n cs) = ConstOpts nty n (third f <$> cs)
mapConstVsC :: (Choice -> ConstValue a -> ConstValue b) -> Choice -> ConstVariants a -> ConstVariants b
mapConstVsC f c (ConstFree vs) = ConstFree (mapC f c vs)
mapConstVsC f c (ConstOpts nty n cs) = ConstOpts nty n (mapC (third . f) c cs)
unconstVs :: ConstVariants a -> [ConstValue a]
unconstVs (ConstFree vs) = vs
unconstVs (ConstOpts nty n cs) = cs <&> \(_,_,v) -> v
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
@@ -169,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
@@ -178,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 nty n os) = ConstOpts nty n (third f <$> os)
consts2variants :: (ConstValue a -> Value) -> ConstVariants a -> Variants
consts2variants f (ConstFree vs) = VarFree (f <$> vs)
consts2variants f (ConstOpts nty n os) = VarOpts nty n (third f <$> os)
normalForm :: Globals -> Term -> Check Term
normalForm g t = value2term g [] (bubble (eval g [] unit t []))
@@ -209,16 +180,19 @@ eval g env s (Abs b x t) [] = VClosure env s (Abs b x t)
eval g env s (Abs b x t) (v:vs) = eval g ((x,v):env) s t vs
eval g env s (Meta i) vs = VMeta i vs
eval g env s (ImplArg t) [] = eval g env s t []
eval g env s (Prod b x t1 t2)[] = let (s1,s2) = split s
eval g env s (Prod b x t1 t2)[]
| x == identW = let (s1,s2) = split s
in VProd b x (eval g env s1 t1 []) (eval g env s2 t2 [])
| otherwise = let (s1,s2) = split s
in VProd b x (eval g env s1 t1 []) (VClosure env s2 t2)
eval g env s (Typed t ty) vs = eval g env s t vs
eval g env s (RecType lbls) [] = VRecType (mapC (\s (lbl,ty) -> (lbl, eval g env s ty [])) s lbls)
eval g env s (RecType lbls) [] = VRecType (mapC (\s (lbl,ty) -> (lbl, True, eval g env s ty [])) s lbls) False
eval g env s (R as) [] = VR (mapC (\s (lbl,(ty,t)) -> (lbl, eval g env s t [])) s as)
eval g env s (P t lbl) vs = let project (VR as) = case lookup lbl as of
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
@@ -226,9 +200,9 @@ eval g env s (P t lbl) vs = let project (VR as) = case lookup lbl a
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) (VRecType as2) = VRecType (foldl (\as (lbl,v) -> update lbl v as) as1 as2)
extend (VFV i fvs) v2 = VFV i (mapVariants (`extend` v2) fvs)
extend v1 (VFV i fvs) = VFV i (mapVariants (v1 `extend`) fvs)
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 (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) []
@@ -256,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
@@ -279,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) []
@@ -302,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) []
@@ -328,7 +302,7 @@ eval g env s (FV ts) vs = VFV s (VarFree (mapC (\s t -> eval g env s t v
eval g env s (Alts d as) [] = let (!s1,!s2) = split s
vd = eval g env s1 d []
vas = mapC (\s (t1,t2) -> let (!s1,!s2) = split s
in (eval g env s1 t1 [],eval g env s2 t2 [])) s2 as
in (eval g env s1 t1 [],eval g env s2 t2 [])) s2 as
in VAlts vd vas
eval g env c (Strs ts) [] = VStrs (mapC (\c t -> eval g env c t []) c ts)
eval g env c (Markup tag as ts) [] =
@@ -338,24 +312,22 @@ eval g env c (Markup tag as ts) [] =
in (VMarkup tag vas vs)
eval g env c (Reset ctl mb_ct t qid) [] = VReset ctl (fmap (\t -> eval g env c t []) mb_ct) (eval g env c t []) qid
eval g env c (TSymCat d r rs) []= VSymCat d r [(i,(fromJust (lookup pv env),ty)) | (i,(pv,ty)) <- rs]
eval g env c t@(Opts (nty,n) cs) vs = if null cs
then VError ("No options in expression:" $$ ppTerm Unqualified 0 t)
else let (c1,c2,c3) = split3 c
(c1ty,c1t) = split c1
vnty = eval g env c1ty (fromJust nty) []
vn = eval g env c1t n []
vcs = mapC evalOpt c2 cs
in VFV c3 (VarOpts vnty vn vcs)
where evalOpt c' ((lty,l),t) = let (c1,c2,c3) = split3 c'
in (eval g env c1 (fromJust lty) [], eval g env c2 l [], eval g env c3 t vs)
eval g env c t vs = VError ("Cannot reduce term" <+> pp t)
eval g env c t@(Opts n cs) vs = if null cs
then VError ("No options in expression:" $$ ppTerm Unqualified 0 t)
else let (c1,c2,c3) = split3 c
vn = eval g env c1 n []
vcs = mapC evalOpt c cs
in VFV c3 (VarOpts vn vcs)
where evalOpt c' (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
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) []
@@ -363,7 +335,8 @@ evalPredef g@(Gl gr pds) c n args =
stdPredef :: Globals -> PredefTable
stdPredef g = Map.fromList
[(cLength, pdArity 1 $\ \g c [v] -> fmap (VInt . genericLength) (value2string g v))
[(cInts, pdArity 1 $\ \g c vs -> Const (case vs of {[VInt i] -> VInts i False; vs -> VApp c (cPredef,cInts) vs}))
,(cLength, pdArity 1 $\ \g c [v] -> fmap (VInt . genericLength) (value2string g v))
,(cTake, pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericTake (value2int g v1) (value2string g v2)))
,(cDrop, pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericDrop (value2int g v1) (value2string g v2)))
,(cTk, pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericTk (value2int g v1) (value2string g v2)))
@@ -389,14 +362,14 @@ 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
data BubbleVariants
= BubbleFree Int
| BubbleOpts Value Value [(Value, Value)]
| BubbleOpts Value [Value]
bubble v = snd (bubble v)
where
@@ -406,7 +379,9 @@ bubble v = snd (bubble v)
bubble (VGen i vs) = liftL (VGen i) vs
bubble (VClosure env c t) = liftL' (\env -> VClosure env c t) env
bubble (VProd bt x v1 v2) = lift2 (VProd bt x) v1 v2
bubble (VRecType as) = liftL' VRecType as
bubble v@(VRecType lbls ext) =
let (union,lbls') = mapAccumL descendR Map.empty lbls
in (union, addVariants (VRecType lbls' ext) union)
bubble (VR as) = liftL' VR as
bubble (VP v l vs) = lift1L (\v vs -> VP v l vs) v vs
bubble (VExtR v1 v2) = lift2 VExtR v1 v2
@@ -426,30 +401,25 @@ bubble v = snd (bubble v)
bubble v@(VFV c (VarFree vs))
| null vs = (Map.empty, v)
| otherwise = let (union,vs') = mapAccumL descend Map.empty vs
b = BubbleFree (length vs)
v' = addVariants (VFV c (VarFree vs')) union
in (Map.insert c (b,1) union, v')
bubble v@(VFV c (VarOpts nty n os))
in (Map.insert c (BubbleFree (length vs),1) union, VFV c (VarFree vs'))
bubble v@(VFV c (VarOpts n os))
| null os = (Map.empty, v)
| otherwise = let (union,os') = mapAccumL (\acc (lty,l,v) -> second (lty,l,) $ descend acc v) Map.empty os
b = BubbleOpts nty n (os <&> \(lty,l,_) -> (lty,l))
v' = addVariants (VFV c (VarOpts nty n os')) union
in (Map.insert c (b,1) union, v')
| otherwise = let (union,os') = mapAccumL (\acc (k,v) -> second (k,) $ descend acc v) Map.empty 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) =
let (union1,attrs') = mapAccumL descend' Map.empty attrs
(union2,vs') = mapAccumL descend union1 vs
in (union2, VMarkup tag attrs' vs')
bubble (VReset ctl mb_cv v id) = lift1 (\v -> VReset ctl mb_cv v id) v
bubble (VReset ctl mb_cv v id) =
let (union,v') = bubble v
in (Map.empty,VReset ctl mb_cv v' id)
bubble (VSymCat d i0 vs) =
let (union,vs') = mapAccumL descendC Map.empty vs
in (union, addVariants (VSymCat d i0 vs') union)
bubble v@(VError _) = lift0 v
bubble v@(VCRecType lbls) =
let (union,lbls') = mapAccumL descendR Map.empty lbls
in (union, addVariants (VCRecType lbls') union)
bubble v@(VCInts _ _) = lift0 v
bubble v@(VInts _ _) = lift0 v
lift0 v = (Map.empty, v)
@@ -519,8 +489,8 @@ bubble v = snd (bubble v)
where
addVariant c (bvs,cnt) v
| cnt > 1 = VFV c $ case bvs of
BubbleFree k -> VarFree (replicate k v)
BubbleOpts nty n os -> VarOpts nty n (os <&> \(lty,l) -> (lty,l,v))
BubbleFree k -> VarFree (replicate k v)
BubbleOpts n os -> VarOpts n (map (\l -> (l,v)) os)
| otherwise = v
unitfy = fmap (\(n,_) -> (n,1))
@@ -546,6 +516,11 @@ update lbl v (a@(lbl',_):as)
| lbl==lbl' = (lbl,v) : as
| otherwise = a : update lbl v as
update3 lbl o v [] = [(lbl,o,v)]
update3 lbl o v (a@(lbl',o',_):as)
| lbl==lbl' = (lbl,o||o',v) : as
| otherwise = a : update3 lbl o v as
patternMatch g s v0 [] = v0
patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
where
@@ -571,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
@@ -630,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)
@@ -670,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
@@ -681,29 +656,25 @@ value2term g xs v = do
[t] -> return t
ts -> return (FV ts)
type Constraint = Value
data MetaState
= Bound Scope Value
| Narrowing Type
| Residuation Scope (Maybe Constraint)
| Residuation Scope
data OptionInfo
= OptionInfo
{ optChoice :: Choice
, optLabelType :: Value
, optLabel :: Value
, optChoices :: [(Value, Value)]
{ 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)
@@ -739,18 +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 []
withState :: State -> EvalM a -> EvalM a
withState state (EvalM f) = EvalM $ \g k _ r ws -> f g k state r ws
init = State input Map.empty Map.empty []
reset :: EvalM a -> EvalM [a]
reset (EvalM f) = EvalM $ \g k state r ws ->
@@ -768,50 +736,62 @@ 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 :: (a -> EvalM b) -> ([(b,State)] -> EvalM b) -> [a] -> EvalM b
try f select xs = EvalM (\g k state r msgs ->
let (res,msgs') = backtrack g xs state [] msgs
try :: Int -> (a -> EvalM b) -> ([b] -> EvalM b) -> [a] -> EvalM b
try sz f select xs = EvalM (\g k state r msgs ->
let (state',res,msgs') = backtrack sz g xs state [] msgs
in case select res of
EvalM f' -> f' g k state r msgs')
EvalM f' -> f' g k state' r msgs')
where
backtrack g [] state res msgs = (res,msgs)
backtrack g (x:xs) state res msgs =
backtrack sz g [] state res msgs = (state,res,msgs)
backtrack sz g (x:xs) state res msgs =
case f x of
EvalM f -> case f g (\x state res msgs -> Success ((x,state):res) msgs) state res msgs of
Fail msg _ -> backtrack g xs state res msgs
Success res msgs -> backtrack g xs state res msgs
EvalM f -> case f g (\y state' (_,ys) msgs -> Success (cut sz state state',y:ys) msgs) state (state,res) msgs of
Fail msg _ -> backtrack sz g xs state res msgs
Success (state,res) msgs -> backtrack sz g xs state res msgs
cut sz state state' = state'{metaVars=Map.mapWithKey select (metaVars state')}
where
select k ms
| k <= sz = ms
| otherwise = case Map.lookup k (metaVars state) of
Just ms -> ms
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 Nothing) 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 ->
k (Map.size (metaVars state)) state r msgs)
getMeta :: MetaId -> EvalM MetaState
getMeta i = EvalM (\g k state r msgs ->
@@ -820,8 +800,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
@@ -832,11 +812,7 @@ value2termM flat xs (VMeta i vs) = do
case mv of
Bound scope v -> do g <- globals
value2termM flat (map fst scope) (apply g v vs)
Residuation _ mb_ctr ->
case mb_ctr of
Just ctr -> do g <- globals
value2termM flat xs (apply g ctr vs)
Nothing -> foldM (\t v -> fmap (App t) (value2termM flat xs v)) (Meta i) vs
Residuation _ -> foldM (\t v -> fmap (App t) (value2termM flat xs v)) (Meta i) vs
value2termM flat xs (VSusp j k vs) =
let v = k (VGen maxBound vs)
in value2termM flat xs v
@@ -848,23 +824,19 @@ value2termM flat xs (VClosure env s (Abs b x t)) = do
x' = mkFreshVar xs x
t <- value2termM flat (x':xs) v
return (Abs b x' t)
value2termM flat xs (VProd b x v1 v2)
| x == identW = do t1 <- value2termM flat xs v1
v2 <- case v2 of
VClosure env s t2 -> do g <- globals
return (eval g env s t2 [])
v2 -> return v2
t2 <- value2termM flat xs v2
return (Prod b x t1 t2)
| otherwise = do t1 <- value2termM flat xs v1
v2 <- case v2 of
VClosure env s t2 -> do g <- globals
return (eval g ((x,VGen (length xs) []):env) s t2 [])
v2 -> return v2
t2 <- value2termM flat (x:xs) v2
return (Prod b (mkFreshVar xs x) t1 t2)
value2termM flat xs (VRecType lbls) = do
lbls <- mapM (\(lbl,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
value2termM flat xs (VClosure env s t) = do
return t
value2termM flat xs (VProd b x v1 (VClosure env c2 t2)) = do
g <- globals
t1 <- value2termM flat xs v1
t2 <- value2termM flat (x:xs) (eval g ((x,VGen (length xs) []):env) c2 t2 [])
return (Prod b (mkFreshVar xs x) t1 t2)
value2termM flat xs (VProd b x v1 v2) = do
t1 <- value2termM flat xs v1
t2 <- value2termM flat xs v2
return (Prod b x t1 t2)
value2termM flat xs (VRecType lbls _) = do
lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
return (RecType lbls)
value2termM flat xs (VR as) = do
as <- mapM (\(lbl,v) -> fmap (\t -> (lbl,(Nothing,t))) (value2termM flat xs v)) as
@@ -932,14 +904,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 nty 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 (lty,l,t) -> case value2termM flat xs t of
EvalM f -> let oi = OptionInfo i nty n (os <&> \(lty,l,_) -> (lty,l))
in f g k (State choices metas (oi:opts)) r msgs
Just (l,t) -> case value2termM flat xs t of
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
@@ -958,7 +936,7 @@ value2termM flat xs (VMarkup tag as vs) = do
as <- mapM (\(id,v) -> value2termM flat xs v >>= \t -> return (id,t)) as
ts <- mapM (value2termM flat xs) vs
return (Markup tag as ts)
value2termM flat xs (VReset ctl mb_cv v qid) = do
value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
ts <- reset (value2termM True xs v)
reduce ctl mb_cv ts
where
@@ -971,11 +949,36 @@ value2termM flat xs (VReset ctl mb_cv v qid) = do
case ts of
[t] -> return t
ts -> return (Markup identW [] ts)
| ctl == cConcat' = do
ts <- case mb_cv of
Just (VInt n) -> return (genericTake n ts)
Nothing -> return ts
_ -> evalError (pp "[concat: .. | ..] requires an integer constant")
case ts of
[] -> mzero
[t] -> return t
ts -> return (Markup identW [] ts)
| ctl == cOne =
case (ts,mb_cv) of
([] ,Nothing) -> mzero
([] ,Just v) -> value2termM flat xs v
(t:ts,_) -> return t
| ctl == cSelect =
case mb_cv of
Just (VInt n) | n >= 0 -> select n ts'
| otherwise -> select (-n-1) (reverse ts')
where
ts' = sortBy compareKey ts
select _ [] = mzero
select 0 (t:ts) =
case t of
R rs -> case lookup (ident2label cp1) rs of
Just (_,t) -> return t
Nothing -> evalError (pp "Missing label p1")
_ -> evalError (pp "The term must be a record")
select n (t:ts) = select (n-1) ts
_ -> evalError (pp "[select: .. | ..] requires an integer constant")
| ctl == cDefault =
case (ts,mb_cv) of
([] ,Nothing) -> mzero
@@ -986,24 +989,29 @@ value2termM flat xs (VReset ctl mb_cv v qid) = do
([], _) -> mzero
([t], _) -> return t
(ts,Just cv) ->
do let cat = showIdent (snd qid)
mn = fst qid
do let Just (mn,id) = mb_qid
cat = showIdent id
ct <- value2termM flat xs cv
t <- listify mn cat ts
return (App (App (QC (mn,identS ("Conj"++cat))) ct) t)
_ -> evalError (pp "[list: .. | ..] requires an argument")
| ctl == cLen =
case mb_cv of
Just cv -> do g <- globals
value2termM True xs (apply g cv [VInt (genericLength ts)])
Nothing -> return (EInt (genericLength ts))
| otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
listify mn cat [t1,t2] = do return (App (App (QC (mn,identS ("Base"++cat))) t1) t2)
listify mn cat (t1:ts) = do t2 <- listify mn cat ts
return (App (App (QC (mn,identS ("Cons"++cat))) t1) t2)
compareKey (R rs1) (R rs2) =
case (lookup (ident2label cp2) rs1, lookup (ident2label cp2) rs2) of
(Just (_,K s1), Just (_,K s2)) -> compare s1 s2
value2termM flat xs (VError msg) = evalError msg
value2termM flat xs (VCRecType lbls) = do
lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
return (RecType lbls)
value2termM flat xs (VCInts Nothing Nothing) = return (App (QC (cPredef,cInts)) (Meta 0))
value2termM flat xs (VCInts (Just min) Nothing) = return (App (QC (cPredef,cInts)) (EInt min))
value2termM flat xs (VCInts _ (Just max)) = return (App (QC (cPredef,cInts)) (EInt max))
value2termM flat xs (VInts n _) = return (App (Q (cPredef,cInts)) (EInt n))
value2termM flat xs v = evalError ("value2termM" <+> ppValue Unqualified 5 v)
@@ -1019,17 +1027,27 @@ pattVars st (PSeq _ _ p1 _ _ p2) = pattVars (pattVars st p1) p2
pattVars st _ = st
ppValue q d (VApp c f vs) = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) vs))
ppValue q d (VMeta i vs) = prec d 4 (hsep ((if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs))
ppValue q d (VSusp i k vs) = prec d 4 (hsep (pp "#susp" : (if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs))
ppValue q d (VGen _ _) = pp "VGen"
ppValue q d (VClosure env c t) = pp "[|" <> ppTerm q 4 t <> pp "|]"
ppValue q d (VProd _ _ _ _) = pp "VProd"
ppValue q d (VRecType _) = pp "VRecType"
ppValue q d (VProd bt x a b) =
if x == identW && bt == Explicit
then prec d 0 (ppValue q 4 a <+> "->" <+> ppValue q 0 b)
else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppValue q 0 a) <+> "->" <+> ppValue q 0 b)
ppValue q d (VRecType xs ext)
| q == Terse = case [cat | (l,_,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
[cat] -> pp cat
_ -> doc
| otherwise = doc
where
doc = braces (fsep (punctuate ';' ([l <+> (if o then ":" else ":?") <+> ppValue q 0 v | (l,o,v) <- xs] ++ [pp ".." | ext])))
ppValue q d (VR _) = pp "VR"
ppValue q d (VP v l vs) = prec d 5 (hsep (ppValue q 5 v <> '.' <> l : map (ppValue q 5) vs))
ppValue q d (VExtR _ _) = pp "VExtR"
ppValue q d (VTable _ _) = pp "VTable"
ppValue q d (VTable kt vt) = prec d 0 (ppValue q 3 kt <+> "=>" <+> ppValue q 0 vt)
ppValue q d (VT t _ _ cs) = "table" <+> ppValue q 0 t <+> '{' $$
nest 2 (vcat (punctuate ';' (map (ppCase q) cs))) $$
'}'
@@ -1045,22 +1063,20 @@ ppValue q d VEmpty = pp "[]"
ppValue q d (VC v1 v2) = prec d 1 (hang (ppValue q 2 v1) 2 ("++" <+> ppValue q 1 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 (VPattType _) = pp "VPattType"
ppValue q d (VFV i (VarFree vs)) = prec d 4 ("variants" <+> pp i <+> braces (fsep (punctuate ';' (map (ppValue q 0) vs))))
ppValue q d (VFV i (VarOpts _ n os)) = prec d 4 ("option" <+> ppValue q 0 n <+> "of" <+> pp i <+> braces (fsep (punctuate ';'
(map (\(_,l,v) -> parens (ppValue q 0 l) <+> "=>" <+> ppValue q 0 v) os))))
ppValue q d (VPattType v) = prec d 4 ("pattern" <+> ppValue q 0 v)
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 (VStrs _) = pp "VStrs"
ppValue q d (VMarkup _ _ _) = pp "VMarkup"
ppValue q d (VReset ctl ct t _) = pp "[" <> pp ctl <>
maybe PP.empty (\v -> pp ':' <+> ppValue q 6 v) ct <>
pp "|" <> ppValue q 0 t <>
pp "]"
ppValue q d (VSymCat i r rs) = pp '<' <> pp i <> pp ',' <> pp r <> pp '>'
ppValue q d (VError msg) = prec d 4 (pp "error" <+> ppTerm q 5 (K (show msg)))
ppValue q d (VCRecType ass) = pp "VCRecType"
ppValue q d (VCInts Nothing Nothing) = prec d 4 (pp "Ints ?")
ppValue q d (VCInts (Just min) Nothing) = prec d 4 (pp "Ints" <+> brackets (pp min <> ".."))
ppValue q d (VCInts Nothing (Just max)) = prec d 4 (pp "Ints" <+> brackets (".." <> pp max))
ppValue q d (VCInts (Just min) (Just max))
| min == max = prec d 4 (pp "Ints" <+> min)
| otherwise = prec d 4 (pp "Ints" <+> brackets (pp min <> ".." <> pp max))
ppValue q d (VInts n ext)
| ext = prec d 4 (pp "Ints" <+> brackets (pp n <> ".."))
| otherwise = prec d 4 (pp "Ints" <+> pp n)
ppAltern q (x,y) = ppValue q 0 x <+> '/' <+> ppValue q 0 y
@@ -1078,7 +1094,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
@@ -1112,7 +1128,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
@@ -1129,9 +1145,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 (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)

36
src/compiler/api/GF/Compile/GeneratePMCFG.hs
View File

@@ -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
@@ -214,11 +223,28 @@ str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs
str2lin (VSymVar d r) = return [SymVar d r]
str2lin VEmpty = return []
str2lin (VC v1 v2) = liftM2 (++) (str2lin v1) (str2lin v2)
str2lin (VAlts def alts) = do def <- str2lin def
alts <- forM alts $ \(v,VStrs vs) -> do
lin <- str2lin v
return (lin,[s | VStr s <- vs])
str2lin v0@(VAlts def alts)
= do def <- str2lin def
alts <- forM alts $ \(v1,v2) -> do
lin <- str2lin v1
ss <- to_strs v2
return (lin,ss)
return [SymKP def alts]
where
to_strs (VStrs vs) = mapM to_str vs
to_strs (VPatt _ _ p) = from_patt p
to_strs v = fail
to_str (VStr s) = return s
to_str _ = fail
from_patt (PAlt p1 p2) = liftM2 (++) (from_patt p1) (from_patt p2)
from_patt (PSeq _ _ p1 _ _ p2) = liftM2 (liftM2 (++)) (from_patt p1) (from_patt p2)
from_patt (PString s) = return [s]
from_patt (PChars cs) = return (map (:[]) cs)
from_patt _ = fail
fail = evalError ("Complex patterns are not supported in:" $$ nest 2 (pp (showValue v0)))
str2lin v = do t <- value2term False [] v
evalError ("the string:" <+> ppTerm Unqualified 0 t $$
"cannot be evaluated at compile time.")

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

@@ -1,315 +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(..)
, bubble
, stdPredef
, unit
, eval
, cleanOptions
, runEvalMWithOpts
, value2termM
, ppValue
)
import GF.Compile.Rename (renameSourceTerm)
import GF.Compile.TypeCheck.ConcreteNew (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)
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) $ \res ->
forM_ res $ \(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
[] -> 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 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

2281
src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
View File

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

232
src/compiler/api/GF/Data/XML.hs
View File

@@ -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,[])

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

@@ -344,7 +344,6 @@ data Info =
deriving Show
type Type = Term
type MTyTerm = (Maybe Term, Term)
type Cat = QIdent
type Fun = QIdent
@@ -374,7 +373,7 @@ data Term =
| P Term Label -- ^ projection: @r.p@
| ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms)
| Opts MTyTerm [Option] -- ^ options: @options s in { e => x ; ... }@
| Opts Term [Option] -- ^ options: @options s in { e => x ; ... }@
| Table Term Term -- ^ table type: @P => A@
| T TInfo [Case] -- ^ table: @table {p => c ; ...}@
@@ -395,12 +394,10 @@ 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]
| Reset Ident (Maybe Term) Term QIdent
| Reset Ident (Maybe Term) Term (Maybe QIdent)
| Alts Term [(Term, Term)] -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
| Strs [Term] -- ^ conditioning prefix strings: @strs {s ; ...}@
@@ -467,7 +464,7 @@ type Equation = ([Patt],Term)
type Labelling = (Label, Type)
type Assign = (Label, (Maybe Type, Term))
type Option = (MTyTerm, Term)
type Option = (Maybe Term, Term)
type Case = (Patt, Term)
--type Cases = ([Patt], Term)
type LocalDef = (Ident, (Maybe Type, Term))

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

@@ -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))) <*>

6
src/compiler/api/GF/Grammar/Lookup.hs
View File

@@ -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

8
src/compiler/api/GF/Grammar/Macros.hs
View File

@@ -404,6 +404,7 @@ composOp co trm =
RecType r -> liftM RecType (mapPairsM co r)
P t i -> liftM2 P (co t) (return i)
ExtR a c -> liftM2 ExtR (co a) (co c)
Opts t os -> liftM2 Opts (co t) (mapM (\(t1,t2) -> liftM2 (,) (maybe (return Nothing) (liftM Just . co) t1) (co t2)) os)
T i cc -> liftM2 (flip T) (mapPairsM co cc) (changeTableType co i)
V ty vs -> liftM2 V (co ty) (mapM co vs)
Let (x,(mt,a)) b -> liftM3 let' (co a) (T.mapM co mt) (co b)
@@ -443,10 +444,14 @@ collectOp :: Monoid m => (Term -> m) -> Term -> m
collectOp co trm = case trm of
App c a -> co c <> co a
Abs _ _ b -> co b
ImplArg t -> co t
Prod _ _ a b -> co a <> co b
Typed a b -> co a <> co b
Example t _ -> co t
S c a -> co c <> co a
Table a c -> co a <> co c
ExtR a c -> co a <> co c
Opts t os -> co t <> mconcatMap (\(a,b) -> maybe mempty co a <> co b) os
R r -> mconcatMap (\ (_,(mt,a)) -> maybe mempty co mt <> co a) r
RecType r -> mconcatMap (co . snd) r
P t i -> co t
@@ -455,9 +460,12 @@ collectOp co trm = case trm of
Let (x,(mt,a)) b -> maybe mempty co mt <> co a <> co b
C s1 s2 -> co s1 <> co s2
Glue s1 s2 -> co s1 <> co s2
EPattType t -> co t
Alts t aa -> let (x,y) = unzip aa in co t <> mconcatMap co (x <> y)
FV ts -> mconcatMap co ts
Strs tt -> mconcatMap co tt
ELincat _ t -> co t
ELin _ t -> co t
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

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

@@ -275,10 +275,10 @@ ParamDef
OperDef :: { [(Ident,Info)] }
OperDef
: Posn LhsNames ':' Exp ';' Posn { [(i, info) | i <- $2, info <- mkOverload (Just (mkL $1 $6 $4)) Nothing ] }
| Posn LhsNames '=' Markup Posn { [(i, info) | i <- $2, info <- mkOverload Nothing (Just (mkL $1 $5 $4))] }
| Posn LhsName ListArg '=' Markup Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing (Just (mkL $1 $6 (mkAbs $3 $5)))] }
| Posn LhsNames ':' Exp '=' Markup Posn { [(i, info) | i <- $2, info <- mkOverload (Just (mkL $1 $7 $4)) (Just (mkL $1 $7 $6))] }
: Posn LhsNames ':' Exp ';' Posn { [(i, info) | i <- $2, info <- mkOverload (Just (mkL $1 $6 $4)) Nothing ] }
| Posn LhsNames '=' Exp ';' Posn { [(i, info) | i <- $2, info <- mkOverload Nothing (Just (mkL $1 $6 $4))] }
| Posn LhsName ListArg '=' Exp ';' Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing (Just (mkL $1 $7 (mkAbs $3 $5)))] }
| Posn LhsNames ':' Exp '=' Exp ';' Posn { [(i, info) | i <- $2, info <- mkOverload (Just (mkL $1 $8 $4)) (Just (mkL $1 $8 $6))] }
LinDef :: { [(Ident,Info)] }
LinDef
@@ -452,7 +452,11 @@ Exp4 :: { Term }
Exp4
: Exp4 Exp5 { App $1 $2 }
| Exp4 '{' Exp '}' { App $1 (ImplArg $3) }
| 'option' Exp 'of' '{' ListOpt '}' { Opts (Nothing, $2) $5 }
| 'option' Exp 'of' '{' ListExp '}' { let toOption t =
case t of
Table x y -> (Just x, y)
y -> (Nothing, y)
in Opts $2 (map toOption $5) }
| 'case' Exp 'of' '{' ListCase '}' { let annot = case $2 of
Typed _ t -> TTyped t
_ -> TRaw
@@ -487,8 +491,7 @@ Exp6
| '{' ListLocDef '}' {% mkR $2 }
| '<' ListTupleComp '>' { R (tuple2record $2) }
| '<' Exp ':' Exp '>' { Typed $2 $4 }
| '[' Control '|' Tag ']' { Reset (fst $2) (snd $2) $4 undefined }
| '[' Control '|' Exp ']' { Reset (fst $2) (snd $2) $4 undefined }
| '[' Control '|' ListMarkup ']' { Reset (fst $2) (snd $2) (mkMarkup $4) Nothing }
| '(' Exp ')' { $2 }
ListExp :: { [Term] }
@@ -609,15 +612,6 @@ ListPattTupleComp
| Patt { [$1] }
| Patt ',' ListPattTupleComp { $1 : $3 }
Opt :: { Option }
Opt
: '(' Exp ')' '=>' Exp { ((Nothing,$2),$5) }
ListOpt :: { [Option] }
ListOpt
: Opt { [$1] }
| Opt ';' ListOpt { $1 : $3 }
Case :: { Case }
Case
: Patt '=>' Exp { ($1,$3) }
@@ -720,14 +714,21 @@ ERHS3 :: { ERHS }
| '(' ERHS0 ')' { $2 }
NLG :: { Map.Map Ident Info }
: ListNLGDef { Map.fromList $1 }
| Posn Tag Posn { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $2))) }
| Posn Exp Posn { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $2))) }
: ListNLGDef { Map.fromList $1 }
| Posn Exp Posn { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $2))) }
| Posn ListMarkup2 Posn { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 (mkMarkup $2)))) }
ListNLGDef :: { [(Ident,Info)] }
ListNLGDef
: {- empty -} { [] }
| 'oper' OperDef ListNLGDef { $2 ++ $3 }
: 'oper' NLGDef { $2 }
| 'oper' NLGDef ListNLGDef { $2 ++ $3 }
NLGDef :: { [(Ident,Info)] }
NLGDef
: Posn LhsNames ':' Exp ';' Posn { [(i, info) | i <- $2, info <- mkOverload (Just (mkL $1 $6 $4)) Nothing ] }
| Posn LhsNames '=' ListMarkup2 Posn { [(i, info) | i <- $2, info <- mkOverload Nothing (Just (mkL $1 $5 (mkMarkup $4)))] }
| Posn LhsName ListArg '=' ListMarkup2 Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing (Just (mkL $1 $6 (mkAbs $3 (mkMarkup $5))))] }
| Posn LhsNames ':' Exp '=' ListMarkup2 Posn { [(i, info) | i <- $2, info <- mkOverload (Just (mkL $1 $7 $4)) (Just (mkL $1 $7 (mkMarkup $6)))] }
Markup :: { Term }
Markup
@@ -746,6 +747,10 @@ ListMarkup :: { [Term] }
| Exp { [$1] }
| Markup ListMarkup { $1 : $2 }
ListMarkup2 :: { [Term] }
: Markup { [$1] }
| Markup ListMarkup2 { $1 : $2 }
Control :: { (Ident,Maybe Term) }
: Ident { ($1, Nothing) }
| Ident ':' Exp6 { ($1, Just $3) }
@@ -884,4 +889,7 @@ mkAlts cs = case cs of
mkL :: Posn -> Posn -> x -> L x
mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) x
mkMarkup [t] = t
mkMarkup ts = Markup identW [] ts
}

183
src/compiler/api/GF/Grammar/PatternMatch.hs
View File

@@ -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
-}

6
src/compiler/api/GF/Grammar/Predef.hs
View File

@@ -63,9 +63,15 @@ cError = identS "error"
-- * Used in the delimited continuations
cConcat = identS "concat"
cConcat' = identS "concat'"
cOne = identS "one"
cSelect = identS "select"
cDefault = identS "default"
cList = identS "list"
cLen = identS "len"
cp1 = identS "p1"
cp2 = identS "p2"
-- * Hacks: dummy identifiers used in various places.
-- Not very nice!

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

@@ -17,6 +17,7 @@ module GF.Grammar.Printer
, ppTerm
, ppPatt
, ppValue
, ppBind
, ppConstrs
, ppQIdent
, ppMeta
@@ -217,12 +218,12 @@ ppTerm q d (S x y) = case x of
'}'
_ -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))
ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
ppTerm q d (Opts t opts) = "option" <+> ppTerm q 0 t <+>"of" <+> '{' $$
nest 2 (vcat (punctuate ';' (map (ppOpt q) opts))) $$
'}'
ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
ppTerm q d (Opts (_,n) cs) = prec d 4 ("option" <+> ppTerm q 0 n <+> "of" <+> braces (fsep (punctuate ';'
(map (\((_,l),t) -> parens (ppTerm q 0 l) <+> "=>" <+> ppTerm q 0 t) cs))))
ppTerm q d (FV es) = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
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)
@@ -270,6 +271,9 @@ ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
ppOpt q (Just p, e) = ppTerm q 0 p <+> "=>" <+> ppTerm q 0 e
ppOpt q (Nothing,e) = ppTerm q 0 e
ppControl q (id,Nothing) = pp id
ppControl q (id,Just t ) = pp id <> ':' <+> ppTerm q 6 t

11
src/compiler/api/GF/Interactive.hs
View File

@@ -14,7 +14,8 @@ import GF.Command.Abstract
import GF.Command.Parse(readCommandLine,pCommand,readTransactionCommand)
import GF.Compile.Rename(renameSourceTerm)
import GF.Compile.TypeCheck.Concrete(inferLType)
import GF.Compile.Compute.Concrete(normalForm,stdPredef,Globals(..))
import qualified GF.Compile.Compute.Concrete as O(normalForm,stdPredef,Globals(..))
import GF.Compile.Compute.Concrete2(stdPredef,Globals(..))
import GF.Compile.GeneratePMCFG(pmcfgForm,type2fields)
import GF.Data.Operations (Err(..))
import GF.Data.Utilities(whenM,repeatM)
@@ -317,11 +318,12 @@ transactionCommand (CreateLin opts f mb_t is_alter) pgf mb_txnid = do
compileLinTerm sgr mo f mb_t ty = do
(t,ty) <- case mb_t of
Just t -> do t <- renameSourceTerm sgr mo (Typed t ty)
(t,ty) <- inferLType sgr [] t
let g = Gl sgr (stdPredef g)
(t,ty) <- inferLType g t
return (t,ty)
Nothing -> case lookupResDef sgr (mo,identS f) of
Ok t -> do ty <- renameSourceTerm sgr mo ty
ty <- normalForm (Gl sgr stdPredef) ty
ty <- O.normalForm (O.Gl sgr O.stdPredef) ty
return (t,ty)
Bad msg -> fail msg
let (ctxt,res_ty) = typeFormCnc ty
@@ -344,7 +346,8 @@ transactionCommand (CreateLincat opts c mb_t) pgf mb_txnid = do
compileLincatTerm sgr mo mb_t = do
t <- case mb_t of
Just t -> do t <- renameSourceTerm sgr mo t
(t,_) <- inferLType sgr [] t
let g = Gl sgr (stdPredef g)
(t,_) <- inferLType g t
return t
Nothing -> case lookupResDef sgr (mo,identS c) of
Ok t -> return t

2
src/compiler/api/GF/Term.hs
View File

@@ -9,4 +9,4 @@ module GF.Term (renameSourceTerm,
import GF.Compile.Rename
import GF.Compile.Compute.Concrete
import GF.Compile.TypeCheck.ConcreteNew
import GF.Compile.TypeCheck.Concrete

12
src/compiler/gf-repl.hs
View File

@@ -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

9
src/compiler/gf.cabal
View File

@@ -121,13 +121,11 @@ library
GF.Compile.GrammarToCanonical
GF.Compile.ReadFiles
GF.Compile.Rename
GF.Compile.Repl
GF.Compile.SubExOpt
GF.Compile.Tags
GF.Compile.ToAPI
GF.Compile.TypeCheck.Abstract
GF.Compile.TypeCheck.Concrete
GF.Compile.TypeCheck.ConcreteNew
GF.Compile.TypeCheck.TC
GF.Compile.Update
GF.Data.BacktrackM
@@ -148,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
@@ -240,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

4
src/runtime/c/pgf/vector.h
View File

@@ -93,8 +93,8 @@ public:
iterator begin() { return iterator(ref<A>::from_ptr(&v()->data[0])); }
iterator end() { return iterator(ref<A>::from_ptr(&v()->data[v()->len])); }
bool operator ==(vector<A>& other) const { return offset==other.as_object(); }
bool operator !=(vector<A>& other) const { return offset!=other.as_object(); }
bool operator ==(vector<A>& other) const { return offset==other.offset; }
bool operator !=(vector<A>& other) const { return offset!=other.offset; }
bool operator ==(object other_offset) const { return offset==other_offset; }
bool operator !=(object other_offset) const { return offset!=other_offset; }

61
src/runtime/python/pypgf.c
View File

@@ -355,6 +355,59 @@ PgfLinearizationOutputIfaceVtbl pypgf_lin_out_iface_vtbl =
(void*) pypgf_lin_out_flush
};
static PyObject*
Concr_tabularLinearize(ConcrObject* self, PyObject *args)
{
ExprObject* pyexpr;
if (!PyArg_ParseTuple(args, "O!", &pgf_ExprType, &pyexpr))
return NULL;
PgfExn err;
PgfText **texts =
pgf_tabular_linearize(self->grammar->db, self->concr, (PgfExpr) pyexpr, NULL,
&marshaller, &err);
if (handleError(err) != PGF_EXN_NONE) {
return NULL;
}
if (texts == NULL) {
Py_RETURN_NONE;
}
PyObject *res = PyList_New(0);
if (!res)
goto fail;
while (texts[0] != NULL && texts[1] != NULL) {
PyObject* pyfield = PyUnicode_FromStringAndSize(texts[0]->text, texts[0]->size);
free(texts[0]); texts++;
if (!pyfield)
goto fail;
PyObject* pylin = PyUnicode_FromStringAndSize(texts[0]->text, texts[0]->size);
free(texts[0]); texts++;
if (!pylin)
goto fail;
PyObject *tup = PyTuple_New(2);
PyTuple_SetItem(tup, 0, pyfield);
PyTuple_SetItem(tup, 1, pylin);
PyList_Append(res, tup);
Py_DECREF(tup);
}
return res;
fail:
Py_XDECREF(res);
while (texts[0]) {
free(texts[0]); texts++;
}
return NULL;
}
static PyObject*
Concr_bracketedLinearize(ConcrObject* self, PyObject *args)
{
@@ -548,10 +601,10 @@ static PyMethodDef Concr_methods[] = {
},
/*{"linearizeAll", (PyCFunction)Concr_linearizeAll, METH_VARARGS | METH_KEYWORDS,
"Takes an abstract tree and linearizes with all variants"
},
},*/
{"tabularLinearize", (PyCFunction)Concr_tabularLinearize, METH_VARARGS,
"Takes an abstract tree and linearizes it to a table containing all fields"
},*/
},
{"bracketedLinearize", (PyCFunction)Concr_bracketedLinearize, METH_VARARGS,
"Takes an abstract tree and linearizes it to a bracketed string"
},
@@ -806,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 *
@@ -892,8 +945,8 @@ _collect_funs(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 *