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

Use GF.Grammar.Printer everywhere instead of PrGrammar

Browse Source
This commit is contained in:
krasimir
2009-09-14 15:13:11 +00:00
parent 3e489086ed
commit 9cebd25eac
19 changed files with 189 additions and 169 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
src/GF/Grammar/Abstract.hs
View File

@@ -19,7 +19,7 @@ module GF.Grammar.Values,
module GF.Grammar.Macros,
module GF.Infra.Ident,
module GF.Grammar.MMacros,
module GF.Grammar.PrGrammar,
module GF.Grammar.Printer,
Grammar
@@ -30,7 +30,7 @@ import GF.Grammar.Values
import GF.Grammar.Macros
import GF.Infra.Ident
import GF.Grammar.MMacros
import GF.Grammar.PrGrammar
import GF.Grammar.Printer
type Grammar = SourceGrammar ---

17
src/GF/Grammar/AppPredefined.hs
View File

@@ -20,8 +20,9 @@ import GF.Data.Operations
import GF.Grammar.Predef
import GF.Grammar.Grammar
import GF.Grammar.Macros
import GF.Grammar.PrGrammar (prt,prt_,prtBad)
import GF.Grammar.Printer
import qualified Data.ByteString.Char8 as BS
import Text.PrettyPrint
-- predefined function type signatures and definitions. AR 12/3/2003.
@@ -56,7 +57,7 @@ typPredefined f
([(varL,typeType),(identW,mkFunType [typeStr] typeStr),(identW,Vr varL)],Vr varL,[])
| f == cTake = return $ mkFunType [typeInt,typeTok] typeTok
| f == cTk = return $ mkFunType [typeInt,typeTok] typeTok
| otherwise = prtBad "unknown in Predef:" f
| otherwise = Bad (render (text "unknown in Predef:" <+> ppIdent f))
varL :: Ident
varL = identC (BS.pack "L")
@@ -89,7 +90,7 @@ appPredefined t = case t of
(EInt i, EInt j) | f == cEqInt -> retb $ if i==j then predefTrue else predefFalse
(EInt i, EInt j) | f == cLessInt -> retb $ if i<j then predefTrue else predefFalse
(EInt i, EInt j) | f == cPlus -> retb $ EInt $ i+j
(_, t) | f == cShow -> retb $ foldr C Empty $ map K $ words $ prt t
(_, t) | f == cShow -> retb $ foldr C Empty $ map K $ words $ render (ppTerm Unqualified 0 t)
(_, K s) | f == cRead -> retb $ Cn (identC (BS.pack s)) --- because of K, only works for atomic tags
(_, t) | f == cToStr -> trm2str t >>= retb
_ -> retb t ---- prtBad "cannot compute predefined" t
@@ -137,11 +138,11 @@ trm2str t = case t of
T _ ((_,s):_) -> trm2str s
TSh _ ((_,s):_) -> trm2str s
V _ (s:_) -> trm2str s
C _ _ -> return $ t
K _ -> return $ t
S c _ -> trm2str c
Empty -> return $ t
_ -> prtBad "cannot get Str from term" t
C _ _ -> return $ t
K _ -> return $ t
S c _ -> trm2str c
Empty -> return $ t
_ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
-- simultaneous recursion on type and term: type arg is essential!
-- But simplify the task by assuming records are type-annotated

3
src/GF/Grammar/Lockfield.hs
View File

@@ -21,14 +21,13 @@ import qualified Data.ByteString.Char8 as BS
import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.Macros
import GF.Grammar.PrGrammar
import GF.Data.Operations
lockRecType :: Ident -> Type -> Err Type
lockRecType c t@(RecType rs) =
let lab = lockLabel c in
return $ if elem lab (map fst rs) || elem (prt c) ["String","Int"]
return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"]
then t --- don't add an extra copy of lock field, nor predef cats
else RecType (rs ++ [(lockLabel c, RecType [])])
lockRecType c t = plusRecType t $ RecType [(lockLabel c, RecType [])]

52
src/GF/Grammar/Lookup.hs
View File

@@ -16,20 +16,20 @@
-----------------------------------------------------------------------------
module GF.Grammar.Lookup (
lookupIdent,
lookupIdentInfo,
lookupIdentInfoIn,
lookupOrigInfo,
lookupResDef,
lookupResDefKind,
lookupIdent,
lookupIdentInfo,
lookupIdentInfoIn,
lookupOrigInfo,
lookupResDef,
lookupResDefKind,
lookupResType,
lookupOverload,
lookupOverload,
lookupParams,
lookupParamValues,
lookupFirstTag,
lookupValueIndex,
lookupIndexValue,
allOrigInfos,
lookupValueIndex,
lookupIndexValue,
allOrigInfos,
allParamValues,
lookupAbsDef,
lookupLincat,
@@ -39,13 +39,17 @@ module GF.Grammar.Lookup (
) where
import GF.Data.Operations
import GF.Grammar.Abstract
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Grammar.Macros
import GF.Grammar.Grammar
import GF.Grammar.Printer
import GF.Grammar.Predef
import GF.Grammar.Lockfield
import Data.List (nub,sortBy)
import Control.Monad
import Text.PrettyPrint
-- whether lock fields are added in reuse
lock c = lockRecType c -- return
@@ -92,7 +96,7 @@ lookupResDefKind gr m c
AnyInd _ n -> look False n c
ResParam _ -> return (QC m c,2)
ResValue _ -> return (QC m c,2)
_ -> Bad $ prt c +++ "is not defined in resource" +++ prt m
_ -> Bad $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m)
lookExt m c =
checks ([look False n c | n <- allExtensions gr m] ++ [return (Q m c,3)])
@@ -112,7 +116,7 @@ lookupResType gr m c = do
AnyInd _ n -> lookupResType gr n c
ResParam _ -> return $ typePType
ResValue (Just (t,_)) -> return $ qualifAnnotPar m t
_ -> Bad $ prt c +++ "has no type defined in resource" +++ prt m
_ -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
where
lookFunType e m c = do
a <- abstractOfConcrete gr m
@@ -124,7 +128,7 @@ lookupResType gr m c = do
AbsFun (Just ty) _ _ -> return $ redirectTerm e ty
AbsCat _ _ -> return typeType
AnyInd _ n -> lookFun e m c n
_ -> prtBad "cannot find type of reused function" c
_ -> Bad (render (text "cannot find type of reused function" <+> ppIdent c))
lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))]
lookupOverload gr m c = do
@@ -138,7 +142,7 @@ lookupOverload gr m c = do
concat tss
AnyInd _ n -> lookupOverload gr n c
_ -> Bad $ prt c +++ "is not an overloaded operation"
_ -> Bad $ render (ppIdent c <+> text "is not an overloaded operation")
-- | returns the original 'Info' and the module where it was found
lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err (Ident,Info)
@@ -157,7 +161,7 @@ lookupParams gr = look True where
case info of
ResParam (Just psm) -> return psm
AnyInd _ n -> look False n c
_ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m
_ -> Bad $ render (ppIdent c <+> text "has no parameters defined in resource" <+> ppIdent m)
lookExt m c =
checks [look False n c | n <- allExtensions gr m]
@@ -177,21 +181,21 @@ lookupFirstTag gr m c = do
vs <- lookupParamValues gr m c
case vs of
v:_ -> return v
_ -> prtBad "no parameter values given to type" c
_ -> Bad (render (text "no parameter values given to type" <+> ppIdent c))
lookupValueIndex :: SourceGrammar -> Type -> Term -> Err Term
lookupValueIndex gr ty tr = do
ts <- allParamValues gr ty
case lookup tr $ zip ts [0..] of
Just i -> return $ Val tr ty i
_ -> Bad $ "no index for" +++ prt tr +++ "in" +++ prt ty
_ -> Bad $ render (text "no index for" <+> ppTerm Unqualified 0 tr <+> text "in" <+> ppTerm Unqualified 0 ty)
lookupIndexValue :: SourceGrammar -> Type -> Int -> Err Term
lookupIndexValue gr ty i = do
ts <- allParamValues gr ty
if i < length ts
then return $ ts !! i
else Bad $ "no value for index" +++ show i +++ "in" +++ prt ty
else Bad $ render (text "no value for index" <+> int i <+> text "in" <+> ppTerm Unqualified 0 ty)
allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)]
allOrigInfos gr m = errVal [] $ do
@@ -209,7 +213,7 @@ allParamValues cnc ptyp = case ptyp of
let (ls,tys) = unzip $ sortByFst r
tss <- mapM allPV tys
return [R (zipAssign ls ts) | ts <- combinations tss]
_ -> prtBad "cannot find parameter values for" ptyp
_ -> Bad (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp))
where
allPV = allParamValues cnc
-- to normalize records and record types
@@ -228,7 +232,7 @@ qualifAnnotPar m t = case t of
_ -> composSafeOp (qualifAnnotPar m) t
lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do
lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
@@ -244,7 +248,7 @@ lookupLincat gr m c = do
case info of
CncCat (Just t) _ _ -> return t
AnyInd _ n -> lookupLincat gr n c
_ -> Bad $ prt c +++ "has no linearization type in" +++ prt m
_ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
-- | this is needed at compile time
lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type
@@ -254,7 +258,7 @@ lookupFunType gr m c = do
case info of
AbsFun (Just t) _ _ -> return t
AnyInd _ n -> lookupFunType gr n c
_ -> prtBad "cannot find type of" c
_ -> Bad (render (text "cannot find type of" <+> ppIdent c))
-- | this is needed at compile time
lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context
@@ -264,7 +268,7 @@ lookupCatContext gr m c = do
case info of
AbsCat (Just co) _ -> return co
AnyInd _ n -> lookupCatContext gr n c
_ -> prtBad "unknown category" c
_ -> Bad (render (text "unknown category" <+> ppIdent c))
-- The first type argument is uncomputed, usually a category symbol.
-- This is a hack to find implicit (= reused) opers.

8
src/GF/Grammar/MMacros.hs
View File

@@ -18,7 +18,7 @@ import GF.Data.Operations
--import GF.Data.Zipper
import GF.Grammar.Grammar
import GF.Grammar.PrGrammar
import GF.Grammar.Printer
import GF.Infra.Ident
import GF.Compile.Refresh
import GF.Grammar.Values
@@ -27,6 +27,8 @@ import GF.Grammar.Macros
import Control.Monad
import qualified Data.ByteString.Char8 as BS
import Text.PrettyPrint
{-
nodeTree :: Tree -> TrNode
argsTree :: Tree -> [Tree]
@@ -178,13 +180,13 @@ val2expP :: Bool -> Val -> Err Exp
val2expP safe v = case v of
VClos g@(_:_) e@(Meta _) -> if safe
then prtBad "unsafe value substitution" v
then Bad (render (text "unsafe value substitution" <+> ppValue Unqualified 0 v))
else substVal g e
VClos g e -> substVal g e
VApp f c -> liftM2 App (val2expP safe f) (val2expP safe c)
VCn c -> return $ qq c
VGen i x -> if safe
then prtBad "unsafe val2exp" v
then Bad (render (text "unsafe val2exp" <+> ppValue Unqualified 0 v))
else return $ Vr $ x --- in editing, no alpha conversions presentv
VRecType xs->do xs <- mapM (\(l,v) -> val2expP safe v >>= \e -> return (l,e)) xs
return (RecType xs)

28
src/GF/Grammar/Macros.hs
View File

@@ -24,11 +24,12 @@ import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.Values
import GF.Grammar.Predef
import GF.Grammar.PrGrammar
import GF.Grammar.Printer
import Control.Monad (liftM, liftM2)
import Data.Char (isDigit)
import Data.List (sortBy)
import Text.PrettyPrint
firstTypeForm :: Type -> Err (Context, Type)
firstTypeForm t = case t of
@@ -50,7 +51,7 @@ qTypeForm t = case t of
QC m c ->
return ([],(m,c),[])
_ ->
prtBad "no normal form of type" t
Bad (render (text "no normal form of type" <+> ppTerm Unqualified 0 t))
qq :: QIdent -> Term
qq (m,c) = Q m c
@@ -94,7 +95,7 @@ getMCat t = case t of
QC m c -> return (m,c)
Sort c -> return (identW, c)
App f _ -> getMCat f
_ -> prtBad "no qualified constant" t
_ -> Bad (render (text "no qualified constant" <+> ppTerm Unqualified 0 t))
typeSkeleton :: Type -> Err ([(Int,MCat)],MCat)
typeSkeleton typ = do
@@ -231,7 +232,7 @@ mkRecType = mkRecTypeN 0
record2subst :: Term -> Err Substitution
record2subst t = case t of
R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs]
_ -> prtBad "record expected, found" t
_ -> Bad (render (text "record expected, found" <+> ppTerm Unqualified 0 t))
typeType, typePType, typeStr, typeTok, typeStrs :: Term
@@ -304,8 +305,8 @@ plusRecType t1 t2 = case (t1, t2) of
(RecType r1, RecType r2) -> case
filter (`elem` (map fst r1)) (map fst r2) of
[] -> return (RecType (r1 ++ r2))
ls -> Bad $ "clashing labels" +++ unwords (map prt ls)
_ -> Bad ("cannot add record types" +++ prt t1 +++ "and" +++ prt t2)
ls -> Bad $ render (text "clashing labels" <+> hsep (map ppLabel ls))
_ -> Bad $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
plusRecord :: Term -> Term -> Err Term
plusRecord t1 t2 =
@@ -314,7 +315,7 @@ plusRecord t1 t2 =
(l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
(_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV
(FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV
_ -> Bad ("cannot add records" +++ prt t1 +++ "and" +++ prt t2)
_ -> Bad $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
-- | default linearization type
defLinType :: Type
@@ -463,7 +464,7 @@ term2patt trm = case termForm trm of
Ok ([], Cn c, []) -> do
return (PMacro c)
_ -> prtBad "no pattern corresponds to term" trm
_ -> Bad $ render (text "no pattern corresponds to term" <+> ppTerm Unqualified 0 trm)
patt2term :: Patt -> Term
patt2term pt = case pt of
@@ -529,7 +530,7 @@ strsFromTerm t = case t of
FV ts -> mapM strsFromTerm ts >>= return . concat
Strs ts -> mapM strsFromTerm ts >>= return . concat
Alias _ _ d -> strsFromTerm d --- should not be needed...
_ -> prtBad "cannot get Str from term" t
_ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
-- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
stringFromTerm :: Term -> String
@@ -708,10 +709,11 @@ isInOneType t = case t of
sortRec :: [(Label,a)] -> [(Label,a)]
sortRec = sortBy ordLabel where
ordLabel (r1,_) (r2,_) = case (prt r1, prt r2) of
("s",_) -> LT
(_,"s") -> GT
(s1,s2) -> compare s1 s2
ordLabel (r1,_) (r2,_) =
case (showIdent (label2ident r1), showIdent (label2ident r2)) of
("s",_) -> LT
(_,"s") -> GT
(s1,s2) -> compare s1 s2

20
src/GF/Grammar/PatternMatch.hs
View File

@@ -21,20 +21,20 @@ import GF.Data.Operations
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Grammar.Macros
import GF.Grammar.PrGrammar
import GF.Grammar.Printer
import Data.List
import Control.Monad
import Text.PrettyPrint
import Debug.Trace
matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution)
matchPattern pts term =
if not (isInConstantForm term)
then prtBad "variables occur in" term
then Bad (render (text "variables occur in" <+> ppTerm Unqualified 0 term))
else do
term' <- mkK term
errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $
errIn (render (text "trying patterns" <+> hsep (punctuate comma (map (ppPatt Unqualified 0 . fst) pts)))) $
findMatch [([p],t) | (p,t) <- pts] [term']
where
-- to capture all Str with string pattern matching
@@ -48,7 +48,7 @@ matchPattern pts term =
K w -> return [w]
C v w -> liftM2 (++) (getS v) (getS w)
Empty -> return []
_ -> prtBad "cannot get string from" s
_ -> Bad (render (text "cannot get string from" <+> ppTerm Unqualified 0 s))
testOvershadow :: [Patt] -> [Term] -> Err [Patt]
testOvershadow pts vs = do
@@ -59,10 +59,10 @@ testOvershadow pts vs = do
findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
findMatch cases terms = case cases of
[] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms))
[] -> Bad (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms))))
(patts,_):_ | length patts /= length terms ->
Bad ("wrong number of args for patterns :" +++
unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms))
Bad (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+>
text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms)))
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
Ok substs -> return (val, concat substs)
_ -> findMatch cc terms
@@ -122,7 +122,7 @@ tryMatch (p,t) = do
(PNeg p',_) -> case tryMatch (p',t) of
Bad _ -> return []
_ -> prtBad "no match with negative pattern" p
_ -> Bad (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p))
(PSeq p1 p2, ([],K s, [])) -> do
let cuts = [splitAt n s | n <- [0 .. length s]]
@@ -138,7 +138,7 @@ tryMatch (p,t) = do
(PChar, ([],K [_], [])) -> return []
(PChars cs, ([],K [c], [])) | elem c cs -> return []
_ -> prtBad "no match in case expr for" t
_ -> Bad (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t))
isInConstantForm :: Term -> Bool
isInConstantForm trm = case trm of

19
src/GF/Grammar/Printer.hs
View File

@@ -16,11 +16,14 @@ module GF.Grammar.Printer
, ppTerm
, ppTermTabular
, ppPatt
, ppValue
, ppConstrs
) where
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Infra.Option
import GF.Grammar.Values
import GF.Grammar.Grammar
import GF.Data.Operations
import Text.PrettyPrint
@@ -225,6 +228,22 @@ ppPatt q d (PFloat f) = double f
ppPatt q d (PString s) = str s
ppPatt q d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs]))
ppValue :: TermPrintQual -> Int -> Val -> Doc
ppValue q d (VGen i x) = ppIdent x <> text "{-" <> int i <> text "-}" ---- latter part for debugging
ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
ppValue q d (VCn (_,c)) = ppIdent c
ppValue q d (VClos env e) = case e of
Meta _ -> ppTerm q d e <> ppEnv env
_ -> ppTerm q d e ---- ++ prEnv env ---- for debugging
ppValue q d (VRecType xs) = braces (hsep (punctuate comma [ppLabel l <> char '=' <> ppValue q 0 v | (l,v) <- xs]))
ppValue q d VType = text "Type"
ppConstrs :: Constraints -> [Doc]
ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> text "<>" <+> ppValue Unqualified 0 w))
ppEnv :: Env -> Doc
ppEnv e = hcat (map (\(x,t) -> braces (ppIdent x <> text ":=" <> ppValue Unqualified 0 t)) e)
str s = doubleQuotes (text s)
ppDecl q (id,typ)

8
src/GF/Grammar/Unify.hs
View File

@@ -18,9 +18,9 @@
module GF.Grammar.Unify (unifyVal) where
import GF.Grammar.Abstract
import GF.Data.Operations
import Text.PrettyPrint
import Data.List (partition)
unifyVal :: Constraints -> Err (Constraints,MetaSubst)
@@ -64,13 +64,13 @@ unify e1 e2 g =
unify b c' g
(App c a, App d b) -> case unify c d g of
Ok g1 -> unify a b g1
_ -> prtBad "fail unify" e1
_ -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1))
(RecType xs,RecType ys) | xs == ys -> return g
_ -> prtBad "fail unify" e1
_ -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1))
extend :: Unifier -> MetaSymb -> Term -> Err Unifier
extend g s t | (t == Meta s) = return g
| occCheck s t = prtBad "occurs check" t
| occCheck s t = Bad (render (text "occurs check" <+> ppTerm Unqualified 0 t))
| True = return ((s, t) : g)
subst_all :: Unifier -> Term -> Err Term