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.Grammar.Lookup (allOpers,allOpersTo)
import GF.Compile.Rename(renameSourceTerm) import GF.Compile.Rename(renameSourceTerm)
import GF.Compile.Compute.Concrete2(normalForm,normalFlatForm,Globals(..),stdPredef) 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.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
import GF.Command.CommandInfo import GF.Command.CommandInfo
@@ -245,10 +245,10 @@ checkComputeTerm os sgr t =
Nothing -> checkError (pp "No source grammar in scope") Nothing -> checkError (pp "No source grammar in scope")
Just mo -> return mo Just mo -> return mo
t <- renameSourceTerm sgr mo t t <- renameSourceTerm sgr mo t
ttys <- inferLType g t (t,_) <- inferLType g t
if isOpt "flat" os if isOpt "flat" os
then fmap concat (mapM (\(t,_) -> fmap (map evalStr) (normalFlatForm g t)) ttys) then fmap (map evalStr) (normalFlatForm g t)
else fmap concat (mapM (\(t,_) -> fmap (singleton . evalStr) (normalForm g t)) ttys) else fmap (singleton . evalStr) (normalForm g t)
where where
-- ** Try to compute pre{...} tokens in token sequences -- ** Try to compute pre{...} tokens in token sequences
singleton x = [x] 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.Infra.Option
import GF.Compile.TypeCheck.Abstract import GF.Compile.TypeCheck.Abstract
import GF.Compile.TypeCheck.Concrete(checkLType,inferLType,ppType) import GF.Compile.TypeCheck.Concrete(checkLType,inferLType)
import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType) import GF.Compile.Compute.Concrete2(normalForm,Globals(..),stdPredef)
import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef)
import GF.Grammar import GF.Grammar
import GF.Grammar.Lexer 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 CncCat mty mdef mref mpr mpmcfg -> do
mty <- case mty of mty <- case mty of
Just (L loc typ) -> chIn loc "linearization type of" $ do Just (L loc typ) -> chIn loc "linearization type of" $ do
(typ,_) <- checkLType gr [] typ typeType (typ,_) <- checkLType g typ typeType
typ <- normalForm (Gl gr stdPredef) typ typ <- normalForm g typ
return (Just (L loc typ)) return (Just (L loc typ))
Nothing -> return Nothing Nothing -> return Nothing
mdef <- case (mty,mdef) of mdef <- case (mty,mdef) of
(Just (L _ typ),Just (L loc def)) -> (Just (L _ typ),Just (L loc def)) ->
chIn loc "default linearization of" $ do 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 (Just (L loc def))
_ -> return Nothing _ -> return Nothing
mref <- case (mty,mref) of mref <- case (mty,mref) of
(Just (L _ typ),Just (L loc ref)) -> (Just (L _ typ),Just (L loc ref)) ->
chIn loc "reference linearization of" $ do 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 (Just (L loc ref))
_ -> return Nothing _ -> return Nothing
mpr <- case mpr of mpr <- case mpr of
(Just (L loc t)) -> (Just (L loc t)) ->
chIn loc "print name of" $ do chIn loc "print name of" $ do
(t,_) <- checkLType gr [] t typeStr (t,_) <- checkLType g t typeStr
return (Just (L loc t)) return (Just (L loc t))
_ -> return Nothing _ -> return Nothing
update sm c (CncCat mty mdef mref mpr mpmcfg) 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 mt <- case (mty,mt) of
(Just (_,cat,cont,val),Just (L loc trm)) -> (Just (_,cat,cont,val),Just (L loc trm)) ->
chIn loc "linearization of" $ do 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 (Just (L loc (etaExpand [] trm cont)))
_ -> return mt _ -> return mt
mpr <- case mpr of mpr <- case mpr of
(Just (L loc t)) -> (Just (L loc t)) ->
chIn loc "print name of" $ do chIn loc "print name of" $ do
(t,_) <- checkLType gr [] t typeStr (t,_) <- checkLType g t typeStr
return (Just (L loc t)) return (Just (L loc t))
_ -> return Nothing _ -> return Nothing
update sm c (CncFun mty mt mpr mpmcfg) 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 (pty', pde') <- case (pty,pde) of
(Just (L loct ty), Just (L locd de)) -> do (Just (L loct ty), Just (L locd de)) -> do
ty' <- chIn loct "operation" $ do ty' <- chIn loct "operation" $ do
(ty,_) <- checkLType gr [] ty typeType (ty,_) <- checkLType g ty typeType
normalForm (Gl gr stdPredef) ty normalForm g ty
(de',_) <- chIn locd "operation" $ (de',_) <- chIn locd "operation" $
checkLType gr [] de ty' checkLType g de ty'
return (Just (L loct ty'), Just (L locd de')) return (Just (L loct ty'), Just (L locd de'))
(Nothing , Just (L locd de)) -> do (Nothing , Just (L locd de)) -> do
(de',ty') <- chIn locd "operation" $ (de',ty') <- chIn locd "operation" $
inferLType gr [] de inferLType g de
return (Just (L locd ty'), Just (L locd de')) return (Just (L locd ty'), Just (L locd de'))
(Just (L loct ty), Nothing) -> do (Just (L loct ty), Nothing) -> do
chIn loct "operation" $ 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') update sm c (ResOper pty' pde')
ResOverload os tysts -> chIn NoLoc "overloading" $ do 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 tysts0 <- lookupOverload gr (fst sm,c) -- check against inherited ones too
tysts1 <- mapM (uncurry $ flip (checkLType gr [])) tysts1 <- sequence
[(mkFunType args val,tr) | (args,(val,tr)) <- tysts0] [checkLType g tr (mkFunType args val) | (args,(val,tr)) <- tysts0]
--- this can only be a partial guarantee, since matching --- this can only be a partial guarantee, since matching
--- with value type is only possible if expected type is given --- with value type is only possible if expected type is given
checkUniq $ --checkUniq $
sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1] -- 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']) update sm c (ResOverload os [(y,x) | (x,y) <- tysts'])
ResParam (Just (L loc pcs)) _ -> do 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 _ -> return sm
where where
gr = prependModule sgr sm gr = prependModule sgr sm
g = Gl gr (stdPredef g)
chIn loc cat = checkInModule cwd (snd sm) loc ("Happened in" <+> cat <+> c) chIn loc cat = checkInModule cwd (snd sm) loc ("Happened in" <+> cat <+> c)
mkParamValues sm c cnt ts [] = return (sm,cnt,[],[]) mkParamValues sm c cnt ts [] = return (sm,cnt,[],[])
mkParamValues sm@(mn,mi) c cnt ts ((p,co):pcs) = do 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 sm <- case lookupIdent p (jments mi) of
Ok (ResValue (L loc _) _) -> update sm p (ResValue (L loc (mkProdSimple co (QC (mn,c)))) cnt) Ok (ResValue (L loc _) _) -> update sm p (ResValue (L loc (mkProdSimple co (QC (mn,c)))) cnt)
Bad msg -> checkError (pp msg) 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 checkUniq xss = case xss of
x:y:xs x:y:xs
| x == y -> checkError $ "ambiguous for type" <+> | x == y -> checkError $ "ambiguous for type" <+>
ppType (mkFunType (tail x) (head x)) ppTerm Terse 0 (mkFunType (tail x) (head x))
| otherwise -> checkUniq $ y:xs | otherwise -> checkUniq $ y:xs
_ -> return () _ -> return ()
@@ -327,6 +327,7 @@ linTypeOfType cnc m (L loc typ) = do
plusRecType vars val plusRecType vars val
return ((Explicit,varX i,rec),cat) return ((Explicit,varX i,rec),cat)
lookLin (_,c) = checks [ --- rather: update with defLinType ? lookLin (_,c) = checks [ --- rather: update with defLinType ?
lookupLincat cnc m c >>= normalForm (Gl cnc stdPredef) lookupLincat cnc m c >>= normalForm g
,return defLinType ,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 #-} {-# LANGUAGE RankNTypes, BangPatterns, GeneralizedNewtypeDeriving, TupleSections #-}
module GF.Compile.Compute.Concrete2 module GF.Compile.Compute.Concrete2
(Env, Scope, Value(..), Variants(..), Constraint, OptionInfo(..), ChoiceMap, cleanOptions, (Env, Scope, Value(..), Variants(..), OptionInfo(..),
ConstValue(..), ConstVariants(..), Globals(..), PredefTable, EvalM, ConstValue(..), Globals(..), PredefTable, EvalM,
mapVariants, mapVariantsC, unvariants, variants2consts, mapVariantsC, unvariants,
mapConstVs, mapConstVsC, unconstVs, consts2variants, runEvalM, runEvalMWithInput, stdPredef, globals,
runEvalM, runEvalMWithOpts, reset, reset1, stdPredef, globals, withState,
PredefImpl, Predef(..), ($\), PredefImpl, Predef(..), ($\),
pdCanonicalArgs, pdArity, pdCanonicalArgs, pdArity,
normalForm, normalFlatForm, normalForm, normalFlatForm,
eval, apply, value2term, value2termM, bubble, patternMatch, vtableSelect, State(..), eval, apply, value2term, value2termM, value2string, value2int, value2float, value2expr, string2value, bubble, patternMatch, vtableSelect, State(..),
newResiduation, getMeta, setMeta, MetaState(..), variants, try, newResiduation, checkpoint, getMeta, setMeta, MetaState(..), variants, try,
evalError, evalWarn, ppValue, Choice(..), unit, poison, split, split3, split4, evalError, evalWarn, ppValue, Choice(..), unit, poison, split, split3, split4, mapC, mapCM) where
mapC, forC, mapCM, forCM) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import GF.Infra.Ident import GF.Infra.Ident
@@ -26,6 +24,7 @@ import GF.Grammar.Predef
import GF.Grammar.Printer hiding (ppValue) import GF.Grammar.Printer hiding (ppValue)
import GF.Grammar.Lockfield(lockLabel) import GF.Grammar.Lockfield(lockLabel)
import GF.Text.Pretty hiding (empty) import GF.Text.Pretty hiding (empty)
import qualified GF.Text.Pretty as PP
import Control.Monad import Control.Monad
import Control.Applicative hiding (Const) import Control.Applicative hiding (Const)
import qualified Control.Applicative as A import qualified Control.Applicative as A
@@ -35,6 +34,7 @@ import Data.Functor ((<&>))
import Data.Maybe (fromMaybe,fromJust) import Data.Maybe (fromMaybe,fromJust)
import Data.List import Data.List
import Data.Char import Data.Char
import PGF2(Expr(..),Literal(..))
type PredefImpl = Globals -> Choice -> [Value] -> ConstValue Value type PredefImpl = Globals -> Choice -> [Value] -> ConstValue Value
newtype Predef = Predef { runPredef :: PredefImpl } newtype Predef = Predef { runPredef :: PredefImpl }
@@ -67,7 +67,7 @@ data Value
| VGen {-# UNPACK #-} !Int [Value] | VGen {-# UNPACK #-} !Int [Value]
| VClosure Env Choice Term | VClosure Env Choice Term
| VProd BindType Ident Value Value | VProd BindType Ident Value Value
| VRecType [(Label, Value)] | VRecType [(Label, Bool, Value)] Bool
| VR [(Label, Value)] | VR [(Label, Value)]
| VP Value Label [Value] | VP Value Label [Value]
| VExtR Value Value | VExtR Value Value
@@ -84,40 +84,35 @@ data Value
| VGlue Value Value | VGlue Value Value
| VPatt Int (Maybe Int) Patt | VPatt Int (Maybe Int) Patt
| VPattType Value | VPattType Value
| VFV Choice Variants | VFV Choice (Variants Value)
| VAlts Value [(Value, Value)] | VAlts Value [(Value, Value)]
| VStrs [Value] | VStrs [Value]
| VMarkup Ident [(Ident,Value)] [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))] | VSymCat Int LIndex [(LIndex, (Value, Type))]
| VError Doc | VError Doc
-- These two constructors are only used internally | VInts Integer Bool
-- in the type checker.
| VCRecType [(Label, Bool, Value)]
| VCInts (Maybe Integer) (Maybe Integer)
third f (a,b,c) = (a, b, f c) data Variants a
= VarFree [a]
| VarOpts Value [(Value, a)]
data Variants instance Functor Variants where
= VarFree [Value] fmap f (VarFree vs) = VarFree (f <$> vs)
| VarOpts Value Value [(Value, Value, Value)] fmap f (VarOpts n cs) = VarOpts n (second f <$> cs)
mapVariants :: (Value -> Value) -> Variants -> Variants mapVariantsC :: (Choice -> a -> b) -> Choice -> Variants a -> Variants b
mapVariants f (VarFree vs) = VarFree (f <$> vs) mapVariantsC f c (VarFree vs) = VarFree (mapC f c vs)
mapVariants f (VarOpts nty n cs) = VarOpts nty n (third f <$> cs) 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 unvariants :: Variants a -> [a]
mapVariantsC f c (VarFree vs) = VarFree (mapC f c vs) unvariants (VarFree vs) = vs
mapVariantsC f c (VarOpts nty n cs) = VarOpts nty n (mapC (third . f) c cs) unvariants (VarOpts n cs) = snd <$> cs
unvariants :: Variants -> [Value]
unvariants (VarFree vs) = vs
unvariants (VarOpts nty n cs) = cs <&> \(_,_,v) -> v
isCanonicalForm :: Bool -> Value -> Bool isCanonicalForm :: Bool -> Value -> Bool
isCanonicalForm flat (VClosure {}) = True isCanonicalForm flat (VClosure {}) = True
isCanonicalForm flat (VProd b x d cod) = isCanonicalForm flat d && isCanonicalForm flat cod isCanonicalForm flat (VProd b x d cod) = isCanonicalForm flat d && isCanonicalForm flat cod
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 (VR {}) = True
isCanonicalForm flat (VTable d cod) = isCanonicalForm flat d && isCanonicalForm flat cod isCanonicalForm flat (VTable d cod) = isCanonicalForm flat d && isCanonicalForm flat cod
isCanonicalForm flat (VT {}) = True isCanonicalForm flat (VT {}) = True
@@ -138,29 +133,13 @@ isCanonicalForm flat _ = False
data ConstValue a data ConstValue a
= Const a = Const a
| CSusp MetaId (Value -> ConstValue a) | CSusp MetaId (Value -> ConstValue a)
| CFV Choice (ConstVariants a) | CFV Choice (Variants (ConstValue a))
| RunTime | RunTime
| NonExist | 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 instance Functor ConstValue where
fmap f (Const c) = Const (f c) fmap f (Const c) = Const (f c)
fmap f (CFV i vs) = CFV i (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 (CSusp i k) = CSusp i (fmap f . k)
fmap f RunTime = RunTime fmap f RunTime = RunTime
fmap f NonExist = NonExist fmap f NonExist = NonExist
@@ -169,8 +148,8 @@ instance Applicative ConstValue where
pure = Const pure = Const
(Const f) <*> (Const x) = Const (f x) (Const f) <*> (Const x) = Const (f x)
(CFV s vs) <*> v2 = CFV s (mapConstVs (<*> v2) vs) (CFV s vs) <*> v2 = CFV s (fmap (<*> v2) vs)
v1 <*> (CFV s vs) = CFV s (mapConstVs (v1 <*>) vs) v1 <*> (CFV s vs) = CFV s (fmap (v1 <*>) vs)
(CSusp i k) <*> v2 = CSusp i (\v -> k v <*> v2) (CSusp i k) <*> v2 = CSusp i (\v -> k v <*> v2)
v1 <*> (CSusp i k) = CSusp i (\v -> v1 <*> k v) v1 <*> (CSusp i k) = CSusp i (\v -> v1 <*> k v)
NonExist <*> _ = NonExist NonExist <*> _ = NonExist
@@ -178,14 +157,6 @@ instance Applicative ConstValue where
RunTime <*> _ = RunTime RunTime <*> _ = RunTime
_ <*> RunTime = RunTime _ <*> RunTime = RunTime
variants2consts :: (Value -> ConstValue a) -> Variants -> ConstVariants a
variants2consts f (VarFree vs) = ConstFree (f <$> vs)
variants2consts f (VarOpts 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 :: Globals -> Term -> Check Term
normalForm g t = value2term g [] (bubble (eval g [] unit t [])) 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 (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 (Meta i) vs = VMeta i vs
eval g env s (ImplArg t) [] = eval g env s t [] 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) 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 (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 (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 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 $$ Nothing -> VError ("Missing value for label" <+> pp lbl $$
"in" <+> pp (P t lbl)) "in" <+> pp (P t lbl))
Just v -> apply g v vs Just v -> apply g v vs
project (VFV s fvs) = VFV s (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 (VMeta i vs) = VSusp i (\v -> project (apply g v vs)) []
project (VSusp i k vs) = VSusp i (\v -> project (apply g (k v) vs)) [] project (VSusp i k vs) = VSusp i (\v -> project (apply g (k v) vs)) []
project v = VP v lbl vs project v = VP v lbl vs
@@ -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 eval g env s (ExtR t1 t2) [] = let (s1,s2) = split s
extend (VR as1) (VR as2) = VR (foldl (\as (lbl,v) -> update lbl v as) as1 as2) extend (VR as1) (VR as2) = VR (foldl (\as (lbl,v) -> update lbl v as) as1 as2)
extend (VRecType as1) (VRecType as2) = VRecType (foldl (\as (lbl,v) -> update lbl v as) as1 as2) extend (VRecType as1 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 (VFV i fvs) v2 = VFV i (fmap (`extend` v2) fvs)
extend v1 (VFV i fvs) = VFV i (mapVariants (v1 `extend`) 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 (VMeta i vs) v2 = VSusp i (\v -> extend (apply g v vs) v2) []
extend v1 (VMeta i vs) = VSusp i (\v -> extend v1 (apply g v vs)) [] extend v1 (VMeta i vs) = VSusp i (\v -> extend v1 (apply g v vs)) []
extend (VSusp i k vs) v2 = VSusp i (\v -> extend (apply g (k v) vs) v2) [] extend (VSusp i k vs) v2 = VSusp i (\v -> extend (apply g (k v) vs) v2) []
@@ -256,13 +230,13 @@ eval g env s (S t1 t2) vs = let (!s1,!s2) = split s
Success tys ws -> case tys of Success tys ws -> case tys of
[ty] -> vtableSelect g v0 ty tvs v2 vs [ty] -> vtableSelect g v0 ty tvs v2 vs
tys -> vtableSelect g v0 (FV (reverse tys)) tvs v2 vs tys -> vtableSelect g v0 (FV (reverse tys)) tvs v2 vs
select (VFV i fvs) = VFV i (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 (VMeta i vs) = VSusp i (\v -> select (apply g v vs)) []
select (VSusp i k vs) = VSusp i (\v -> select (apply g (k v) vs)) [] select (VSusp i k vs) = VSusp i (\v -> select (apply g (k v) vs)) []
select v1 = v0 select v1 = v0
-- FIXME: options=[] is definitely not correct and this shouldn't be using value2termM at all -- 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 in select v1
eval g env s (Let (x,(_,t1)) t2) vs = let (!s1,!s2) = split s eval g env s (Let (x,(_,t1)) t2) vs = let (!s1,!s2) = split s
@@ -279,8 +253,8 @@ eval g env s (C t1 t2) [] = let (!s1,!s2) = split s
concat v1 VEmpty = v1 concat v1 VEmpty = v1
concat VEmpty v2 = v2 concat VEmpty v2 = v2
concat (VFV i fvs) v2 = VFV i (mapVariants (`concat` v2) fvs) concat (VFV i fvs) v2 = VFV i (fmap (`concat` v2) fvs)
concat v1 (VFV i fvs) = VFV i (mapVariants (v1 `concat`) 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 (VMeta i vs) v2 = VSusp i (\v -> concat (apply g v vs) v2) []
concat v1 (VMeta i vs) = VSusp i (\v -> concat v1 (apply g v vs)) [] concat v1 (VMeta i vs) = VSusp i (\v -> concat v1 (apply g v vs)) []
concat (VSusp i k vs) v2 = VSusp i (\v -> concat (apply g (k v) vs) v2) [] concat (VSusp i k vs) v2 = VSusp i (\v -> concat (apply g (k v) vs) v2) []
@@ -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 v (VAlts d vas) = VAlts (glue v d) [(glue v v',ss) | (v',ss) <- vas]
glue (VAlts d vas) (VStr s) = pre d vas s glue (VAlts d vas) (VStr s) = pre d vas s
glue (VAlts d vas) v = glue d v glue (VAlts d vas) v = glue d v
glue (VFV i fvs) v2 = VFV i (mapVariants (`glue` v2) fvs) glue (VFV i fvs) v2 = VFV i (fmap (`glue` v2) fvs)
glue v1 (VFV i fvs) = VFV i (mapVariants (v1 `glue`) 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 (VMeta i vs) v2 = VSusp i (\v -> glue (apply g v vs) v2) []
glue v1 (VMeta i vs) = VSusp i (\v -> glue v1 (apply g v vs)) [] glue v1 (VMeta i vs) = VSusp i (\v -> glue v1 (apply g v vs)) []
glue (VSusp i k vs) v2 = VSusp i (\v -> glue (apply g (k v) vs) v2) [] glue (VSusp i k vs) v2 = VSusp i (\v -> glue (apply g (k v) vs) v2) []
@@ -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 eval g env s (Alts d as) [] = let (!s1,!s2) = split s
vd = eval g env s1 d [] vd = eval g env s1 d []
vas = mapC (\s (t1,t2) -> let (!s1,!s2) = split s vas = mapC (\s (t1,t2) -> let (!s1,!s2) = split s
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 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 (Strs ts) [] = VStrs (mapC (\c t -> eval g env c t []) c ts)
eval g env c (Markup tag as 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) in (VMarkup tag vas vs)
eval g env c (Reset ctl mb_ct t qid) [] = VReset ctl (fmap (\t -> eval g env c t []) mb_ct) (eval g env c t []) qid eval g env c (Reset ctl mb_ct t qid) [] = VReset ctl (fmap (\t -> eval g env c t []) mb_ct) (eval g env c t []) qid
eval g env c (TSymCat d r rs) []= VSymCat d r [(i,(fromJust (lookup pv env),ty)) | (i,(pv,ty)) <- rs] eval g env c (TSymCat d r rs) []= VSymCat d r [(i,(fromJust (lookup pv env),ty)) | (i,(pv,ty)) <- rs]
eval g env c t@(Opts (nty,n) cs) vs = if null cs eval g env c t@(Opts n cs) vs = if null cs
then VError ("No options in expression:" $$ ppTerm Unqualified 0 t) then VError ("No options in expression:" $$ ppTerm Unqualified 0 t)
else let (c1,c2,c3) = split3 c else let (c1,c2,c3) = split3 c
(c1ty,c1t) = split c1 vn = eval g env c1 n []
vnty = eval g env c1ty (fromJust nty) [] vcs = mapC evalOpt c cs
vn = eval g env c1t n [] in VFV c3 (VarOpts vn vcs)
vcs = mapC evalOpt c2 cs where evalOpt c' (Just l, t) = let (c1,c2) = split c' in (eval g env c1 l [], eval g env c2 t vs)
in VFV c3 (VarOpts vnty vn vcs) evalOpt c' (Nothing,t) = let v = eval g env c' t vs in (v, v)
where evalOpt c' ((lty,l),t) = let (c1,c2,c3) = split3 c' eval g env c t vs = VError ("Cannot reduce term" <+> pp t)
in (eval g env c1 (fromJust lty) [], eval g env c2 l [], eval g env c3 t vs)
eval g env c t vs = VError ("Cannot reduce term" <+> pp t)
evalPredef :: Globals -> Choice -> Ident -> [Value] -> Value evalPredef :: Globals -> Choice -> Ident -> [Value] -> Value
evalPredef g@(Gl gr pds) c n args = evalPredef g@(Gl gr pds) c n args =
case Map.lookup n pds of case Map.lookup n pds of
Nothing -> VApp c (cPredef,n) args Nothing -> VApp c (cPredef,n) args
Just def -> let valueOf (Const res) = res 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 (CSusp i k) = VSusp i (valueOf . k) []
valueOf RunTime = VApp c (cPredef,n) args valueOf RunTime = VApp c (cPredef,n) args
valueOf NonExist = VApp c (cPredef,cNonExist) [] valueOf NonExist = VApp c (cPredef,cNonExist) []
@@ -363,7 +335,8 @@ evalPredef g@(Gl gr pds) c n args =
stdPredef :: Globals -> PredefTable stdPredef :: Globals -> PredefTable
stdPredef g = Map.fromList 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))) ,(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))) ,(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))) ,(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) | m == cPredef = evalPredef g c n (vs0++vs)
| otherwise = VApp c f (vs0++vs) | otherwise = VApp c f (vs0++vs)
apply g (VGen i vs0) vs = VGen i (vs0++vs) apply g (VGen i vs0) vs = VGen i (vs0++vs)
apply g (VFV i fvs) vs = VFV i (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 (VS v1 v2 vs') vs = VS v1 v2 (vs'++vs)
apply g (VClosure env s (Abs b x t)) (v:vs) = eval g ((x,v):env) s t vs apply g (VClosure env s (Abs b x t)) (v:vs) = eval g ((x,v):env) s t vs
apply g v [] = v apply g v [] = v
data BubbleVariants data BubbleVariants
= BubbleFree Int = BubbleFree Int
| BubbleOpts Value Value [(Value, Value)] | BubbleOpts Value [Value]
bubble v = snd (bubble v) bubble v = snd (bubble v)
where where
@@ -406,7 +379,9 @@ bubble v = snd (bubble v)
bubble (VGen i vs) = liftL (VGen i) vs bubble (VGen i vs) = liftL (VGen i) vs
bubble (VClosure env c t) = liftL' (\env -> VClosure env c t) env 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 (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 (VR as) = liftL' VR as
bubble (VP v l vs) = lift1L (\v vs -> VP v l vs) v vs bubble (VP v l vs) = lift1L (\v vs -> VP v l vs) v vs
bubble (VExtR v1 v2) = lift2 VExtR v1 v2 bubble (VExtR v1 v2) = lift2 VExtR v1 v2
@@ -426,30 +401,25 @@ bubble v = snd (bubble v)
bubble v@(VFV c (VarFree vs)) bubble v@(VFV c (VarFree vs))
| null vs = (Map.empty, v) | null vs = (Map.empty, v)
| otherwise = let (union,vs') = mapAccumL descend Map.empty vs | otherwise = let (union,vs') = mapAccumL descend Map.empty vs
b = BubbleFree (length vs) in (Map.insert c (BubbleFree (length vs),1) union, VFV c (VarFree vs'))
v' = addVariants (VFV c (VarFree vs')) union bubble v@(VFV c (VarOpts n os))
in (Map.insert c (b,1) union, v')
bubble v@(VFV c (VarOpts nty n os))
| null os = (Map.empty, v) | null os = (Map.empty, v)
| otherwise = let (union,os') = mapAccumL (\acc (lty,l,v) -> second (lty,l,) $ descend acc v) Map.empty os | otherwise = let (union,os') = mapAccumL (\acc (k,v) -> second (k,) $ descend acc v) Map.empty os
b = BubbleOpts nty n (os <&> \(lty,l,_) -> (lty,l)) in (Map.insert c (BubbleOpts n (map fst os),1) union, VFV c (VarOpts n os'))
v' = addVariants (VFV c (VarOpts nty n os')) union
in (Map.insert c (b,1) union, v')
bubble (VAlts v vs) = lift1L2 VAlts v vs bubble (VAlts v vs) = lift1L2 VAlts v vs
bubble (VStrs vs) = liftL VStrs vs bubble (VStrs vs) = liftL VStrs vs
bubble (VMarkup tag attrs vs) = bubble (VMarkup tag attrs vs) =
let (union1,attrs') = mapAccumL descend' Map.empty attrs let (union1,attrs') = mapAccumL descend' Map.empty attrs
(union2,vs') = mapAccumL descend union1 vs (union2,vs') = mapAccumL descend union1 vs
in (union2, VMarkup tag attrs' 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) = bubble (VSymCat d i0 vs) =
let (union,vs') = mapAccumL descendC Map.empty vs let (union,vs') = mapAccumL descendC Map.empty vs
in (union, addVariants (VSymCat d i0 vs') union) in (union, addVariants (VSymCat d i0 vs') union)
bubble v@(VError _) = lift0 v bubble v@(VError _) = lift0 v
bubble v@(VCRecType lbls) = bubble v@(VInts _ _) = lift0 v
let (union,lbls') = mapAccumL descendR Map.empty lbls
in (union, addVariants (VCRecType lbls') union)
bubble v@(VCInts _ _) = lift0 v
lift0 v = (Map.empty, v) lift0 v = (Map.empty, v)
@@ -519,8 +489,8 @@ bubble v = snd (bubble v)
where where
addVariant c (bvs,cnt) v addVariant c (bvs,cnt) v
| cnt > 1 = VFV c $ case bvs of | cnt > 1 = VFV c $ case bvs of
BubbleFree k -> VarFree (replicate k v) BubbleFree k -> VarFree (replicate k v)
BubbleOpts nty n os -> VarOpts nty n (os <&> \(lty,l) -> (lty,l,v)) BubbleOpts n os -> VarOpts n (map (\l -> (l,v)) os)
| otherwise = v | otherwise = v
unitfy = fmap (\(n,_) -> (n,1)) unitfy = fmap (\(n,_) -> (n,1))
@@ -546,6 +516,11 @@ update lbl v (a@(lbl',_):as)
| lbl==lbl' = (lbl,v) : as | lbl==lbl' = (lbl,v) : as
| otherwise = a : update 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 [] = v0
patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0 patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
where 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, VMeta i vs) -> VSusp i (\v -> match' env p ps eqs (apply g v vs) args) []
(p, VGen i vs) -> v0 (p, VGen i vs) -> v0
(p, VSusp i k vs) -> VSusp i (\v -> match' env p ps eqs (apply g (k v) vs) args) [] (p, VSusp i k vs) -> VSusp i (\v -> match' env p ps eqs (apply g (k v) vs) args) []
(p, VFV s vs) -> VFV s (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) (PP q qs, VApp c r vs)
| q == r -> match env (qs++ps) eqs (vs++args) | q == r -> match env (qs++ps) eqs (vs++args)
(PR pas, VR as) -> matchRec env (reverse pas) as ps eqs args (PR pas, VR as) -> matchRec env (reverse pas) as ps eqs args
@@ -630,7 +605,7 @@ vtableSelect g v0 ty cs v2 vs =
where where
select (Const (i,_)) = cs !! i select (Const (i,_)) = cs !! i
select (CSusp i k) = VSusp i (\v -> select (k v)) [] select (CSusp i k) = VSusp i (\v -> select (k v)) []
select (CFV s vs) = VFV s (consts2variants select vs) select (CFV c vs) = VFV c (fmap select vs)
select _ = v0 select _ = v0
value2index (VMeta i vs) ty = CSusp i (\v -> value2index (apply g v vs) ty) value2index (VMeta i vs) ty = CSusp i (\v -> value2index (apply g v vs) ty)
@@ -670,7 +645,7 @@ vtableSelect g v0 ty cs v2 vs =
Gl gr _ = g Gl gr _ = g
value2index (VInt n) ty value2index (VInt n) ty
| Just max <- isTypeInts ty = Const (fromIntegral n,fromIntegral max+1) | Just max <- isTypeInts ty = Const (fromIntegral n,fromIntegral max+1)
value2index (VFV i vs) ty = CFV i (variants2consts (\v -> value2index v ty) vs) value2index (VFV c vs) ty = CFV c (fmap (\v -> value2index v ty) vs)
value2index v ty = RunTime value2index v ty = RunTime
@@ -681,29 +656,25 @@ value2term g xs v = do
[t] -> return t [t] -> return t
ts -> return (FV ts) ts -> return (FV ts)
type Constraint = Value
data MetaState data MetaState
= Bound Scope Value = Bound Scope Value
| Narrowing Type | Narrowing Type
| Residuation Scope (Maybe Constraint) | Residuation Scope
data OptionInfo data OptionInfo
= OptionInfo = OptionInfo
{ optChoice :: Choice { optChoice :: Choice
, optLabelType :: Value , optValue :: Int
, optLabel :: Value , optLabel :: Value
, optChoices :: [(Value, Value)] , optChoices :: [Value]
} }
type ChoiceMap = Map.Map Choice Int
data State data State
= State = State
{ choices :: ChoiceMap { input :: [(Choice, Int)]
, choices :: Map.Map Choice Int
, metaVars :: Map.Map MetaId MetaState , metaVars :: Map.Map MetaId MetaState
, options :: [OptionInfo] , options :: [OptionInfo]
} }
cleanOptions :: [OptionInfo] -> ChoiceMap -> ChoiceMap
cleanOptions opts = Map.filterWithKey (\k _ -> any (\opt -> k == optChoice opt) opts)
type Cont r = State -> r -> [Message] -> CheckResult r [Message] type Cont r = State -> r -> [Message] -> CheckResult r [Message]
newtype EvalM a = EvalM (forall r . Globals -> (a -> Cont r) -> Cont r) newtype EvalM a = EvalM (forall r . Globals -> (a -> Cont r) -> Cont r)
@@ -739,18 +710,15 @@ runEvalM g (EvalM f) = Check $ \(es,ws) ->
Fail msg ws -> Fail msg (es,ws) Fail msg ws -> Fail msg (es,ws)
Success xs ws -> Success (reverse xs) (es,ws) Success xs ws -> Success (reverse xs) (es,ws)
where where
empty = State Map.empty Map.empty [] empty = State [] Map.empty Map.empty []
runEvalMWithOpts :: Globals -> ChoiceMap -> EvalM a -> Check [(a, ChoiceMap, [OptionInfo])] runEvalMWithInput :: Globals -> [(Choice,Int)] -> EvalM a -> Check [(a, [OptionInfo])]
runEvalMWithOpts g cs (EvalM f) = Check $ \(es,ws) -> runEvalMWithInput g input (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 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) Fail msg ws -> Fail msg (es,ws)
Success xs ws -> Success (reverse xs) (es,ws) Success xs ws -> Success (reverse xs) (es,ws)
where where
init = State cs Map.empty [] init = State input Map.empty Map.empty []
withState :: State -> EvalM a -> EvalM a
withState state (EvalM f) = EvalM $ \g k _ r ws -> f g k state r ws
reset :: EvalM a -> EvalM [a] reset :: EvalM a -> EvalM [a]
reset (EvalM f) = EvalM $ \g k state r ws -> reset (EvalM f) = EvalM $ \g k state r ws ->
@@ -768,50 +736,62 @@ globals :: EvalM Globals
globals = EvalM (\g k -> k g) globals = EvalM (\g k -> k g)
variants :: Choice -> [a] -> EvalM a 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 case Map.lookup c choices of
Just j -> k (xs !! j) state r msgs Just j -> k (xs !! j) state r msgs
Nothing -> backtrack 0 xs k choices metas opts r msgs) Nothing -> backtrack 0 xs k input choices metas opts r msgs)
where where
backtrack j [] k choices metas opts r msgs = Success r msgs backtrack j [] k input choices metas opts r msgs = Success r msgs
backtrack j (x:xs) k choices metas opts r msgs = backtrack j (x:xs) k input choices metas opts r msgs =
case k x (State (Map.insert c j choices) metas opts) r msgs of case k x (State input (Map.insert c j choices) metas opts) r msgs of
Fail msg msgs -> Fail msg msgs Fail msg msgs -> Fail msg msgs
Success r msgs -> backtrack (j+1) xs k choices metas 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' :: 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 case Map.lookup c choices of
Just j -> case f (xs !! j) of Just j -> case f (xs !! j) of
EvalM f -> f g k state r msgs EvalM f -> f g k state r msgs
Nothing -> case backtrack g 0 xs choices metas opts [] msgs of Nothing -> case backtrack g 0 xs input choices metas opts [] msgs of
Fail msg msgs -> Fail msg msgs Fail msg msgs -> Fail msg msgs
Success ts msgs -> k (FV (reverse ts)) state r msgs) Success ts msgs -> k (FV (reverse ts)) state r msgs)
where where
backtrack g j [] choices metas opts ts msgs = Success ts msgs backtrack g j [] input choices metas opts ts msgs = Success ts msgs
backtrack g j (x:xs) choices metas opts ts msgs = backtrack g j (x:xs) input choices metas opts ts msgs =
case f x of case f x of
EvalM f -> case f g (\t st ts msgs -> Success (t:ts) msgs) (State (Map.insert c j choices) metas 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 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 :: Int -> (a -> EvalM b) -> ([b] -> EvalM b) -> [a] -> EvalM b
try f select xs = EvalM (\g k state r msgs -> try sz f select xs = EvalM (\g k state r msgs ->
let (res,msgs') = backtrack g xs state [] msgs let (state',res,msgs') = backtrack sz g xs state [] msgs
in case select res of in case select res of
EvalM f' -> f' g k state r msgs') EvalM f' -> f' g k state' r msgs')
where where
backtrack g [] state res msgs = (res,msgs) backtrack sz g [] state res msgs = (state,res,msgs)
backtrack g (x:xs) state res msgs = backtrack sz g (x:xs) state res msgs =
case f x of case f x of
EvalM f -> case f g (\x state res msgs -> Success ((x,state):res) msgs) state res msgs of 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 g xs state res msgs Fail msg _ -> backtrack sz g xs state res msgs
Success res msgs -> backtrack 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 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 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 :: MetaId -> EvalM MetaState
getMeta i = EvalM (\g k state r msgs -> 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) Nothing -> Fail ("Metavariable ?"<>pp i<+>"is not defined") msgs)
setMeta :: MetaId -> MetaState -> EvalM () setMeta :: MetaId -> MetaState -> EvalM ()
setMeta i ms = EvalM (\g k (State choices metas opts) r msgs -> setMeta i ms = EvalM (\g k (State input choices metas opts) r msgs ->
let state' = State choices (Map.insert i ms metas) opts let state' = State input choices (Map.insert i ms metas) opts
in k () state' r msgs) in k () state' r msgs)
value2termM :: Bool -> [Ident] -> Value -> EvalM Term value2termM :: Bool -> [Ident] -> Value -> EvalM Term
@@ -832,11 +812,7 @@ value2termM flat xs (VMeta i vs) = do
case mv of case mv of
Bound scope v -> do g <- globals Bound scope v -> do g <- globals
value2termM flat (map fst scope) (apply g v vs) value2termM flat (map fst scope) (apply g v vs)
Residuation _ mb_ctr -> Residuation _ -> foldM (\t v -> fmap (App t) (value2termM flat xs v)) (Meta i) vs
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
value2termM flat xs (VSusp j k vs) = value2termM flat xs (VSusp j k vs) =
let v = k (VGen maxBound vs) let v = k (VGen maxBound vs)
in value2termM flat xs v in value2termM flat xs v
@@ -848,23 +824,19 @@ value2termM flat xs (VClosure env s (Abs b x t)) = do
x' = mkFreshVar xs x x' = mkFreshVar xs x
t <- value2termM flat (x':xs) v t <- value2termM flat (x':xs) v
return (Abs b x' t) return (Abs b x' t)
value2termM flat xs (VProd b x v1 v2) value2termM flat xs (VClosure env s t) = do
| x == identW = do t1 <- value2termM flat xs v1 return t
v2 <- case v2 of value2termM flat xs (VProd b x v1 (VClosure env c2 t2)) = do
VClosure env s t2 -> do g <- globals g <- globals
return (eval g env s t2 []) t1 <- value2termM flat xs v1
v2 -> return v2 t2 <- value2termM flat (x:xs) (eval g ((x,VGen (length xs) []):env) c2 t2 [])
t2 <- value2termM flat xs v2 return (Prod b (mkFreshVar xs x) t1 t2)
return (Prod b x t1 t2) value2termM flat xs (VProd b x v1 v2) = do
| otherwise = do t1 <- value2termM flat xs v1 t1 <- value2termM flat xs v1
v2 <- case v2 of t2 <- value2termM flat xs v2
VClosure env s t2 -> do g <- globals return (Prod b x t1 t2)
return (eval g ((x,VGen (length xs) []):env) s t2 []) value2termM flat xs (VRecType lbls _) = do
v2 -> return v2 lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
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
return (RecType lbls) return (RecType lbls)
value2termM flat xs (VR as) = do value2termM flat xs (VR as) = do
as <- mapM (\(lbl,v) -> fmap (\t -> (lbl,(Nothing,t))) (value2termM flat xs v)) as 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 value2termM True xs (VFV i (VarFree vs)) = do
v <- variants i vs v <- variants i vs
value2termM True xs v value2termM True xs v
value2termM False xs (VFV i (VarFree vs)) = variants' i (value2termM False xs) vs value2termM False xs (VFV c (VarFree vs)) = variants' c (value2termM False xs) vs
value2termM flat xs (VFV i (VarOpts nty n os)) = value2termM flat xs (VFV c (VarOpts n os)) =
EvalM $ \g k (State choices metas opts) r msgs -> EvalM $ \g k (State input choices metas opts) r msgs ->
let j = fromMaybe 0 (Map.lookup i choices) 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 in case os `maybeAt` j of
Just (lty,l,t) -> case value2termM flat xs t of Just (l,t) -> case value2termM flat xs t of
EvalM f -> let oi = OptionInfo i nty n (os <&> \(lty,l,_) -> (lty,l)) EvalM f -> f g k (State input' choices' metas opts') r msgs
in f g k (State choices metas (oi:opts)) r msgs
Nothing -> Fail ("Index" <+> j <+> "out of bounds for option:" $$ ppValue Unqualified 0 n) msgs Nothing -> Fail ("Index" <+> j <+> "out of bounds for option:" $$ ppValue Unqualified 0 n) msgs
value2termM flat xs (VPatt min max p) = return (EPatt min max p) value2termM flat xs (VPatt min max p) = return (EPatt min max p)
value2termM flat xs (VPattType v) = do t <- value2termM flat xs v 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 as <- mapM (\(id,v) -> value2termM flat xs v >>= \t -> return (id,t)) as
ts <- mapM (value2termM flat xs) vs ts <- mapM (value2termM flat xs) vs
return (Markup tag as ts) 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) ts <- reset (value2termM True xs v)
reduce ctl mb_cv ts reduce ctl mb_cv ts
where where
@@ -971,11 +949,36 @@ value2termM flat xs (VReset ctl mb_cv v qid) = do
case ts of case ts of
[t] -> return t [t] -> return t
ts -> return (Markup identW [] ts) 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 = | ctl == cOne =
case (ts,mb_cv) of case (ts,mb_cv) of
([] ,Nothing) -> mzero ([] ,Nothing) -> mzero
([] ,Just v) -> value2termM flat xs v ([] ,Just v) -> value2termM flat xs v
(t:ts,_) -> return t (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 = | ctl == cDefault =
case (ts,mb_cv) of case (ts,mb_cv) of
([] ,Nothing) -> mzero ([] ,Nothing) -> mzero
@@ -986,24 +989,29 @@ value2termM flat xs (VReset ctl mb_cv v qid) = do
([], _) -> mzero ([], _) -> mzero
([t], _) -> return t ([t], _) -> return t
(ts,Just cv) -> (ts,Just cv) ->
do let cat = showIdent (snd qid) do let Just (mn,id) = mb_qid
mn = fst qid cat = showIdent id
ct <- value2termM flat xs cv ct <- value2termM flat xs cv
t <- listify mn cat ts t <- listify mn cat ts
return (App (App (QC (mn,identS ("Conj"++cat))) ct) t) return (App (App (QC (mn,identS ("Conj"++cat))) ct) t)
_ -> evalError (pp "[list: .. | ..] requires an argument") _ -> 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") | 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,t2] = do return (App (App (QC (mn,identS ("Base"++cat))) t1) t2)
listify mn cat (t1:ts) = do t2 <- listify mn cat ts listify mn cat (t1:ts) = do t2 <- listify mn cat ts
return (App (App (QC (mn,identS ("Cons"++cat))) t1) t2) 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 (VError msg) = evalError msg
value2termM flat xs (VCRecType lbls) = do value2termM flat xs (VInts n _) = return (App (Q (cPredef,cInts)) (EInt n))
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 v = evalError ("value2termM" <+> ppValue Unqualified 5 v) 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 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 (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 (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 (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 (VGen _ _) = pp "VGen"
ppValue q d (VClosure env c t) = pp "[|" <> ppTerm q 4 t <> pp "|]" ppValue q d (VClosure env c t) = pp "[|" <> ppTerm q 4 t <> pp "|]"
ppValue q d (VProd _ _ _ _) = pp "VProd" ppValue q d (VProd bt x a b) =
ppValue q d (VRecType _) = pp "VRecType" 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 (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 (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 (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 <+> '{' $$ ppValue q d (VT t _ _ cs) = "table" <+> ppValue q 0 t <+> '{' $$
nest 2 (vcat (punctuate ';' (map (ppCase q) cs))) $$ 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 (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 (VGlue v1 v2) = prec d 2 (ppValue q 3 v1 <+> '+' <+> ppValue q 2 v2)
ppValue q d (VPatt _ _ _) = pp "VPatt" ppValue q d (VPatt _ _ _) = pp "VPatt"
ppValue q d (VPattType _) = pp "VPattType" ppValue q d (VPattType v) = prec d 4 ("pattern" <+> ppValue q 0 v)
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 vs) = prec d 4 ("variants" <+> pp i <+> braces (fsep (punctuate ';' (map (ppValue q 0) (unvariants vs)))))
ppValue q d (VFV i (VarOpts _ n os)) = prec d 4 ("option" <+> ppValue q 0 n <+> "of" <+> pp i <+> braces (fsep (punctuate ';'
(map (\(_,l,v) -> parens (ppValue q 0 l) <+> "=>" <+> ppValue q 0 v) os))))
ppValue q d (VAlts e xs) = prec d 4 ("pre" <+> braces (ppValue q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs)))) ppValue q d (VAlts e xs) = prec d 4 ("pre" <+> braces (ppValue q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
ppValue q d (VStrs _) = pp "VStrs" ppValue q d (VStrs _) = pp "VStrs"
ppValue q d (VMarkup _ _ _) = pp "VMarkup" ppValue q d (VMarkup _ _ _) = pp "VMarkup"
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 (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 (VError msg) = prec d 4 (pp "error" <+> ppTerm q 5 (K (show msg)))
ppValue q d (VCRecType ass) = pp "VCRecType" ppValue q d (VInts n ext)
ppValue q d (VCInts Nothing Nothing) = prec d 4 (pp "Ints ?") | ext = prec d 4 (pp "Ints" <+> brackets (pp n <> ".."))
ppValue q d (VCInts (Just min) Nothing) = prec d 4 (pp "Ints" <+> brackets (pp min <> "..")) | otherwise = prec d 4 (pp "Ints" <+> pp n)
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))
ppAltern q (x,y) = ppValue q 0 x <+> '/' <+> ppValue q 0 y 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) value2string' g (VC v1 v2) b ws qs = concat v1 (value2string' g v2 b ws qs)
where where
concat v1 (Const (b,ws,qs)) = value2string' g v1 b ws qs concat v1 (Const (b,ws,qs)) = value2string' g v1 b ws qs
concat v1 (CFV i vs) = CFV i (mapConstVs (concat v1) vs) concat v1 (CFV c vs) = CFV c (fmap (concat v1) vs)
concat v1 res = res concat v1 res = res
value2string' g (VApp c q []) b ws qs value2string' g (VApp c q []) b ws qs
| q == (cPredef,cNonExist) = NonExist | q == (cPredef,cNonExist) = NonExist
@@ -1112,7 +1128,7 @@ value2string' g (VAlts vd vas) b ws qs =
| or [startsWith s w | VStr s <- ss] = value2string' g v | or [startsWith s w | VStr s <- ss] = value2string' g v
| otherwise = pre vd vas w | otherwise = pre vd vas w
value2string' g (VFV s vs) b ws qs = value2string' g (VFV s vs) b ws qs =
CFV s (variants2consts (\v -> value2string' g v b ws qs) vs) CFV s (fmap (\v -> value2string' g v b ws qs) vs)
value2string' _ _ _ _ _ = RunTime value2string' _ _ _ _ _ = RunTime
startsWith [] _ = True 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 (VMeta i vs) = CSusp i (\v -> value2int g (apply g v vs))
value2int g (VSusp i k vs) = CSusp i (\v -> value2int g (apply g (k v) vs)) value2int g (VSusp i k vs) = CSusp i (\v -> value2int g (apply g (k v) vs))
value2int g (VInt n) = Const n value2int g (VInt n) = Const n
value2int g (VFV s vs) = CFV s (variants2consts (value2int g) vs) value2int g (VFV s vs) = CFV s (fmap (value2int g) vs)
value2int g _ = RunTime 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 } newtype Choice = Choice { unchoice :: Integer }
deriving (Eq,Ord,Pretty,Show) 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) type2metaTerm gr d ms r rs (Table p q)
| count == 1 = do (ms',r',t) <- type2metaTerm gr d ms r rs q | count == 1 = do (ms',r',t) <- type2metaTerm gr d ms r rs q
return (ms',r+(r'-r),T (TTyped p) [(PW,t)]) 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) <- (ms',delta,t) <-
fixST $ \(~(_,delta,_)) -> fixST $ \(~(_,delta,_)) ->
do (ms',r',t) <- type2metaTerm gr d ms r ((delta,(pv,p)):rs) q do (ms',r',t) <- type2metaTerm gr d ms r ((delta,(pv,p)):rs) q
return (ms',r'-r,t) return (ms',r'-r,t)
return (ms',r+delta*count,T (TTyped p) [(PV pv,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 where
collectParams (QC q) = [q]
collectParams (Table _ t) = collectParams t
collectParams t = collectOp collectParams t
count = case allParamValues gr p of count = case allParamValues gr p of
Ok ts -> length ts Ok ts -> length ts
Bad msg -> error msg 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 (VSymVar d r) = return [SymVar d r]
str2lin VEmpty = return [] str2lin VEmpty = return []
str2lin (VC v1 v2) = liftM2 (++) (str2lin v1) (str2lin v2) str2lin (VC v1 v2) = liftM2 (++) (str2lin v1) (str2lin v2)
str2lin (VAlts def alts) = do def <- str2lin def str2lin v0@(VAlts def alts)
alts <- forM alts $ \(v,VStrs vs) -> do = do def <- str2lin def
lin <- str2lin v alts <- forM alts $ \(v1,v2) -> do
return (lin,[s | VStr s <- vs]) lin <- str2lin v1
ss <- to_strs v2
return (lin,ss)
return [SymKP def alts] 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 str2lin v = do t <- value2term False [] v
evalError ("the string:" <+> ppTerm Unqualified 0 t $$ evalError ("the string:" <+> ppTerm Unqualified 0 t $$
"cannot be evaluated at compile time.") "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 -- Module : XML
-- --
-- Utilities for creating XML documents. -- 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 import GF.Data.Utilities
data XML = Data String | Tag String [Attr] [XML] | ETag String [Attr] | Comment String | Empty 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 :: (XML -> XML) -> XML -> XML
bottomUpXML f (Tag n attrs cs) = f (Tag n attrs (map (bottomUpXML f) cs)) bottomUpXML f (Tag n attrs cs) = f (Tag n attrs (map (bottomUpXML f) cs))
bottomUpXML f x = f x 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 deriving Show
type Type = Term type Type = Term
type MTyTerm = (Maybe Term, Term)
type Cat = QIdent type Cat = QIdent
type Fun = QIdent type Fun = QIdent
@@ -374,7 +373,7 @@ data Term =
| P Term Label -- ^ projection: @r.p@ | P Term Label -- ^ projection: @r.p@
| ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms) | ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms)
| Opts MTyTerm [Option] -- ^ options: @options s in { e => x ; ... }@ | Opts Term [Option] -- ^ options: @options s in { e => x ; ... }@
| Table Term Term -- ^ table type: @P => A@ | Table Term Term -- ^ table type: @P => A@
| T TInfo [Case] -- ^ table: @table {p => c ; ...}@ | T TInfo [Case] -- ^ table: @table {p => c ; ...}@
@@ -395,12 +394,10 @@ data Term =
| ELincat Ident Term -- ^ boxed linearization type of Ident | ELincat Ident Term -- ^ boxed linearization type of Ident
| ELin Ident Term -- ^ boxed linearization of type 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 ; ... }@ | FV [Term] -- ^ alternatives in free variation: @variants { s ; ... }@
| Markup Ident [(Ident,Term)] [Term] | 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 ; ...}@ | Alts Term [(Term, Term)] -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
| Strs [Term] -- ^ conditioning prefix strings: @strs {s ; ...}@ | Strs [Term] -- ^ conditioning prefix strings: @strs {s ; ...}@
@@ -467,7 +464,7 @@ type Equation = ([Patt],Term)
type Labelling = (Label, Type) type Labelling = (Label, Type)
type Assign = (Label, (Maybe Type, Term)) type Assign = (Label, (Maybe Type, Term))
type Option = (MTyTerm, Term) type Option = (Maybe Term, Term)
type Case = (Patt, Term) type Case = (Patt, Term)
--type Cases = ([Patt], Term) --type Cases = ([Patt], Term)
type LocalDef = (Ident, (Maybe Type, Term)) type LocalDef = (Ident, (Maybe Type, Term))

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 (EPattType t) = makeObj [("patttype",term2json t)]
term2json (ELincat id t) = makeObj [("lincat",showJSON id), ("term",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 (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 (FV ts) = makeObj [("variants",showJSON (map term2json ts))]
term2json (Markup tag attrs children) = makeObj [ ("tag",showJSON tag) term2json (Markup tag attrs children) = makeObj [ ("tag",showJSON tag)
, ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json val)) attrs)) , ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json val)) attrs))
@@ -175,7 +174,6 @@ json2term o = Vr <$> o!:"vr"
<|> EPattType <$> o!<"patttype" <|> EPattType <$> o!<"patttype"
<|> ELincat <$> o!:"lincat" <*> o!<"term" <|> ELincat <$> o!:"lincat" <*> o!<"term"
<|> ELin <$> o!:"lin" <*> o!<"term" <|> ELin <$> o!:"lin" <*> o!<"term"
<|> AdHocOverload <$> (o!:"overloaded" >>= mapM json2term)
<|> FV <$> (o!:"variants" >>= mapM json2term) <|> FV <$> (o!:"variants" >>= mapM json2term)
<|> Markup <$> (o!:"tag") <*> <|> Markup <$> (o!:"tag") <*>
(o!:"attrs" >>= mapM (\(attr,val) -> fmap ((,)attr) (json2term val))) <*> (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 Nothing -> notFound i
where where
cnvType xs (PGF2.DTyp hypos cat es) = 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 = appHypos [] xs t es =
foldl (appExpr 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) RecType r -> liftM RecType (mapPairsM co r)
P t i -> liftM2 P (co t) (return i) P t i -> liftM2 P (co t) (return i)
ExtR a c -> liftM2 ExtR (co a) (co c) 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) T i cc -> liftM2 (flip T) (mapPairsM co cc) (changeTableType co i)
V ty vs -> liftM2 V (co ty) (mapM co vs) 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) 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 collectOp co trm = case trm of
App c a -> co c <> co a App c a -> co c <> co a
Abs _ _ b -> co b Abs _ _ b -> co b
ImplArg t -> co t
Prod _ _ a b -> co a <> co b 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 S c a -> co c <> co a
Table a c -> co a <> co c Table a c -> co a <> co c
ExtR 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 R r -> mconcatMap (\ (_,(mt,a)) -> maybe mempty co mt <> co a) r
RecType r -> mconcatMap (co . snd) r RecType r -> mconcatMap (co . snd) r
P t i -> co t 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 Let (x,(mt,a)) b -> maybe mempty co mt <> co a <> co b
C s1 s2 -> co s1 <> co s2 C s1 s2 -> co s1 <> co s2
Glue 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) Alts t aa -> let (x,y) = unzip aa in co t <> mconcatMap co (x <> y)
FV ts -> mconcatMap co ts FV ts -> mconcatMap co ts
Strs tt -> mconcatMap co tt Strs tt -> mconcatMap co tt
ELincat _ t -> co t
ELin _ t -> co t
Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap co cs Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap co cs
Reset _ ct t _-> maybe mempty co ct <> co t Reset _ ct t _-> maybe mempty co ct <> co t
_ -> mempty -- covers K, Vr, Cn, Sort _ -> 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 :: { [(Ident,Info)] }
OperDef OperDef
: 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 (Just (mkL $1 $6 $4)) Nothing ] }
| Posn LhsNames '=' Markup Posn { [(i, info) | i <- $2, info <- mkOverload Nothing (Just (mkL $1 $5 $4))] } | Posn LhsNames '=' Exp ';' Posn { [(i, info) | i <- $2, info <- mkOverload Nothing (Just (mkL $1 $6 $4))] }
| Posn LhsName ListArg '=' Markup Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing (Just (mkL $1 $6 (mkAbs $3 $5)))] } | Posn LhsName ListArg '=' Exp ';' Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing (Just (mkL $1 $7 (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 '=' Exp ';' Posn { [(i, info) | i <- $2, info <- mkOverload (Just (mkL $1 $8 $4)) (Just (mkL $1 $8 $6))] }
LinDef :: { [(Ident,Info)] } LinDef :: { [(Ident,Info)] }
LinDef LinDef
@@ -452,7 +452,11 @@ Exp4 :: { Term }
Exp4 Exp4
: Exp4 Exp5 { App $1 $2 } : Exp4 Exp5 { App $1 $2 }
| Exp4 '{' Exp '}' { App $1 (ImplArg $3) } | Exp4 '{' Exp '}' { App $1 (ImplArg $3) }
| 'option' Exp 'of' '{' ListOpt '}' { Opts (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 | 'case' Exp 'of' '{' ListCase '}' { let annot = case $2 of
Typed _ t -> TTyped t Typed _ t -> TTyped t
_ -> TRaw _ -> TRaw
@@ -487,8 +491,7 @@ Exp6
| '{' ListLocDef '}' {% mkR $2 } | '{' ListLocDef '}' {% mkR $2 }
| '<' ListTupleComp '>' { R (tuple2record $2) } | '<' ListTupleComp '>' { R (tuple2record $2) }
| '<' Exp ':' Exp '>' { Typed $2 $4 } | '<' Exp ':' Exp '>' { Typed $2 $4 }
| '[' Control '|' Tag ']' { Reset (fst $2) (snd $2) $4 undefined } | '[' Control '|' ListMarkup ']' { Reset (fst $2) (snd $2) (mkMarkup $4) Nothing }
| '[' Control '|' Exp ']' { Reset (fst $2) (snd $2) $4 undefined }
| '(' Exp ')' { $2 } | '(' Exp ')' { $2 }
ListExp :: { [Term] } ListExp :: { [Term] }
@@ -609,15 +612,6 @@ ListPattTupleComp
| Patt { [$1] } | Patt { [$1] }
| Patt ',' ListPattTupleComp { $1 : $3 } | Patt ',' ListPattTupleComp { $1 : $3 }
Opt :: { Option }
Opt
: '(' Exp ')' '=>' Exp { ((Nothing,$2),$5) }
ListOpt :: { [Option] }
ListOpt
: Opt { [$1] }
| Opt ';' ListOpt { $1 : $3 }
Case :: { Case } Case :: { Case }
Case Case
: Patt '=>' Exp { ($1,$3) } : Patt '=>' Exp { ($1,$3) }
@@ -720,14 +714,21 @@ ERHS3 :: { ERHS }
| '(' ERHS0 ')' { $2 } | '(' ERHS0 ')' { $2 }
NLG :: { Map.Map Ident Info } NLG :: { Map.Map Ident Info }
: ListNLGDef { Map.fromList $1 } : 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))) }
| 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 :: { [(Ident,Info)] }
ListNLGDef ListNLGDef
: {- empty -} { [] } : 'oper' NLGDef { $2 }
| 'oper' OperDef ListNLGDef { $2 ++ $3 } | '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 :: { Term }
Markup Markup
@@ -746,6 +747,10 @@ ListMarkup :: { [Term] }
| Exp { [$1] } | Exp { [$1] }
| Markup ListMarkup { $1 : $2 } | Markup ListMarkup { $1 : $2 }
ListMarkup2 :: { [Term] }
: Markup { [$1] }
| Markup ListMarkup2 { $1 : $2 }
Control :: { (Ident,Maybe Term) } Control :: { (Ident,Maybe Term) }
: Ident { ($1, Nothing) } : Ident { ($1, Nothing) }
| Ident ':' Exp6 { ($1, Just $3) } | Ident ':' Exp6 { ($1, Just $3) }
@@ -884,4 +889,7 @@ mkAlts cs = case cs of
mkL :: Posn -> Posn -> x -> L x mkL :: Posn -> Posn -> x -> L x
mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) 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 -- * Used in the delimited continuations
cConcat = identS "concat" cConcat = identS "concat"
cConcat' = identS "concat'"
cOne = identS "one" cOne = identS "one"
cSelect = identS "select"
cDefault = identS "default" cDefault = identS "default"
cList = identS "list" cList = identS "list"
cLen = identS "len"
cp1 = identS "p1"
cp2 = identS "p2"
-- * Hacks: dummy identifiers used in various places. -- * Hacks: dummy identifiers used in various places.
-- Not very nice! -- Not very nice!

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

@@ -17,6 +17,7 @@ module GF.Grammar.Printer
, ppTerm , ppTerm
, ppPatt , ppPatt
, ppValue , ppValue
, ppBind
, ppConstrs , ppConstrs
, ppQIdent , ppQIdent
, ppMeta , 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)) _ -> 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 (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 (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))]) ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
ppTerm q d (Opts (_,n) cs) = prec d 4 ("option" <+> ppTerm q 0 n <+> "of" <+> braces (fsep (punctuate ';'
(map (\((_,l),t) -> parens (ppTerm q 0 l) <+> "=>" <+> ppTerm q 0 t) cs))))
ppTerm q d (FV es) = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))) ppTerm q d (FV es) = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs)))) ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
ppTerm q d (Strs es) = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))) 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) 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 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,Nothing) = pp id
ppControl q (id,Just t ) = pp id <> ':' <+> ppTerm q 6 t 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.Command.Parse(readCommandLine,pCommand,readTransactionCommand)
import GF.Compile.Rename(renameSourceTerm) import GF.Compile.Rename(renameSourceTerm)
import GF.Compile.TypeCheck.Concrete(inferLType) 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.Compile.GeneratePMCFG(pmcfgForm,type2fields)
import GF.Data.Operations (Err(..)) import GF.Data.Operations (Err(..))
import GF.Data.Utilities(whenM,repeatM) 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 compileLinTerm sgr mo f mb_t ty = do
(t,ty) <- case mb_t of (t,ty) <- case mb_t of
Just t -> do t <- renameSourceTerm sgr mo (Typed t ty) 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) return (t,ty)
Nothing -> case lookupResDef sgr (mo,identS f) of Nothing -> case lookupResDef sgr (mo,identS f) of
Ok t -> do ty <- renameSourceTerm sgr mo ty 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) return (t,ty)
Bad msg -> fail msg Bad msg -> fail msg
let (ctxt,res_ty) = typeFormCnc ty 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 compileLincatTerm sgr mo mb_t = do
t <- case mb_t of t <- case mb_t of
Just t -> do t <- renameSourceTerm sgr mo t Just t -> do t <- renameSourceTerm sgr mo t
(t,_) <- inferLType sgr [] t let g = Gl sgr (stdPredef g)
(t,_) <- inferLType g t
return t return t
Nothing -> case lookupResDef sgr (mo,identS c) of Nothing -> case lookupResDef sgr (mo,identS c) of
Ok t -> return t 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.Rename
import GF.Compile.Compute.Concrete 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.GrammarToCanonical
GF.Compile.ReadFiles GF.Compile.ReadFiles
GF.Compile.Rename GF.Compile.Rename
GF.Compile.Repl
GF.Compile.SubExOpt GF.Compile.SubExOpt
GF.Compile.Tags GF.Compile.Tags
GF.Compile.ToAPI GF.Compile.ToAPI
GF.Compile.TypeCheck.Abstract GF.Compile.TypeCheck.Abstract
GF.Compile.TypeCheck.Concrete GF.Compile.TypeCheck.Concrete
GF.Compile.TypeCheck.ConcreteNew
GF.Compile.TypeCheck.TC GF.Compile.TypeCheck.TC
GF.Compile.Update GF.Compile.Update
GF.Data.BacktrackM GF.Data.BacktrackM
@@ -148,7 +146,6 @@ library
GF.Grammar.Lookup GF.Grammar.Lookup
GF.Grammar.Macros GF.Grammar.Macros
GF.Grammar.Parser GF.Grammar.Parser
GF.Grammar.PatternMatch
GF.Grammar.Predef GF.Grammar.Predef
GF.Grammar.Printer GF.Grammar.Printer
GF.Grammar.ShowTerm GF.Grammar.ShowTerm
@@ -240,12 +237,6 @@ executable gf
build-depends: base >= 4.6 && <5, directory>=1.2, gf build-depends: base >= 4.6 && <5, directory>=1.2, gf
ghc-options: -threaded 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 test-suite gf-tests
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
main-is: run.hs 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 begin() { return iterator(ref<A>::from_ptr(&v()->data[0])); }
iterator end() { return iterator(ref<A>::from_ptr(&v()->data[v()->len])); } 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.offset; }
bool operator !=(vector<A>& other) const { return offset!=other.as_object(); } 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; }
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 (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* static PyObject*
Concr_bracketedLinearize(ConcrObject* self, PyObject *args) Concr_bracketedLinearize(ConcrObject* self, PyObject *args)
{ {
@@ -548,10 +601,10 @@ static PyMethodDef Concr_methods[] = {
}, },
/*{"linearizeAll", (PyCFunction)Concr_linearizeAll, METH_VARARGS | METH_KEYWORDS, /*{"linearizeAll", (PyCFunction)Concr_linearizeAll, METH_VARARGS | METH_KEYWORDS,
"Takes an abstract tree and linearizes with all variants" "Takes an abstract tree and linearizes with all variants"
}, },*/
{"tabularLinearize", (PyCFunction)Concr_tabularLinearize, METH_VARARGS, {"tabularLinearize", (PyCFunction)Concr_tabularLinearize, METH_VARARGS,
"Takes an abstract tree and linearizes it to a table containing all fields" "Takes an abstract tree and linearizes it to a table containing all fields"
},*/ },
{"bracketedLinearize", (PyCFunction)Concr_bracketedLinearize, METH_VARARGS, {"bracketedLinearize", (PyCFunction)Concr_bracketedLinearize, METH_VARARGS,
"Takes an abstract tree and linearizes it to a bracketed string" "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) { if (PyList_Append((PyObject*) clo->collection, py_name) != 0) {
err->type = PGF_EXN_OTHER_ERROR; err->type = PGF_EXN_OTHER_ERROR;
Py_DECREF(py_name);
} }
Py_DECREF(py_name);
} }
static PyObject * 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) { if (PyList_Append((PyObject*) clo->collection, py_name) != 0) {
err->type = PGF_EXN_OTHER_ERROR; err->type = PGF_EXN_OTHER_ERROR;
Py_DECREF(py_name);
} }
Py_DECREF(py_name);
} }
static PyObject * static PyObject *