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

use ByteString internally in Ident, CId and Label

Browse Source
This commit is contained in:
kr.angelov
2008-05-21 13:10:54 +00:00
parent 529374caaa
commit c544ef3182
65 changed files with 6275 additions and 6432 deletions
Download Patch File Download Diff File Expand all files Collapse all files

32
src-3.0/GF/Devel/CheckGrammar.hs
View File

@@ -1,3 +1,4 @@
{-# LANGUAGE PatternGuards #-}
----------------------------------------------------------------------
-- |
-- Module : CheckGrammar
@@ -29,11 +30,12 @@ import GF.Infra.Modules
import GF.Grammar.Refresh ----
import GF.Devel.TypeCheck
import GF.Grammar.Values (cPredefAbs) ---
import GF.Grammar.Predef (cPredef, cPredefAbs) ---
import GF.Grammar.PrGrammar
import GF.Grammar.Lookup
import GF.Grammar.LookAbs
import GF.Grammar.Predef
import GF.Grammar.Macros
import GF.Grammar.ReservedWords ----
import GF.Grammar.PatternMatch
@@ -334,16 +336,10 @@ computeLType gr t = do
checkInContext g $ comp t
where
comp ty = case ty of
App (Q (IC "Predef") (IC "Ints")) _ -> return ty ---- shouldn't be needed
Q (IC "Predef") (IC "Int") -> return ty ---- shouldn't be needed
Q (IC "Predef") (IC "Float") -> return ty ---- shouldn't be needed
Q (IC "Predef") (IC "Error") -> return ty ---- shouldn't be needed
Q m c | elem c [cPredef,cPredefAbs] -> return ty
Q m c | elem c [zIdent "Int"] ->
return $ linTypeInt
Q m c | elem c [zIdent "Float",zIdent "String"] -> return defLinType ----
_ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
| ty == typeInt -> return ty ---- shouldn't be needed
| ty == typeFloat -> return ty ---- shouldn't be needed
| ty == typeError -> return ty ---- shouldn't be needed
Q m ident -> checkIn ("module" +++ prt m) $ do
ty' <- checkErr (lookupResDef gr m ident)
@@ -525,7 +521,7 @@ inferLType gr trm = case trm of
check2 (flip justCheck typeStr) Glue s1 s2 typeStr ---- typeTok
---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
Strs (Cn (IC "#conflict") : ts) -> do
Strs (Cn c : ts) | c == cConflict -> do
trace ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) (infer $ head ts)
-- checkWarn ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts))
-- infer $ head ts
@@ -964,7 +960,7 @@ checkIfEqLType env t u trm = do
alpha g t u = case (t,u) of
-- error (the empty type!) is subtype of any other type
(_,Q (IC "Predef") (IC "Error")) -> True
(_,u) | u == typeError -> True
-- contravariance
(Prod x a b, Prod y c d) -> alpha g c a && alpha ((x,y):g) b d
@@ -976,13 +972,9 @@ checkIfEqLType env t u trm = do
(ExtR r s, t) -> alpha g r t || alpha g s t
-- the following say that Ints n is a subset of Int and of Ints m >= n
(App (Q (IC "Predef") (IC "Ints")) (EInt n),
App (Q (IC "Predef") (IC "Ints")) (EInt m)) -> m >= n
(App (Q (IC "Predef") (IC "Ints")) (EInt n),
Q (IC "Predef") (IC "Int")) -> True ---- check size!
(Q (IC "Predef") (IC "Int"), ---- why this ???? AR 11/12/2005
App (Q (IC "Predef") (IC "Ints")) (EInt n)) -> True
(t,u) | Just m <- isTypeInts t, Just n <- isTypeInts t -> m >= n
| Just _ <- isTypeInts t, u == typeInt -> True ---- check size!
| t == typeInt, Just _ <- isTypeInts t -> True ---- why this ???? AR 11/12/2005
---- this should be made in Rename
(Q m a, Q n b) | a == b -> elem m (allExtendsPlus env n)

2
src-3.0/GF/Devel/Compile/SourceToGF.hs
View File

@@ -235,7 +235,7 @@ transCatDef x = case x of
constyp = mkProd (cont ++ [cd, M.mkDecl lc]) lc
consfund = (consId, absFun constyp) ---- (yes constyp) (yes G.EData))
return [catd,nilfund,consfund]
mkId x i = if isWildIdent x then (mkIdent "x" i) else x
mkId x i = if isWildIdent x then (identV "x" i) else x
transFunDef :: FunDef -> Err ([Ident], G.Type)
transFunDef x = case x of

11
src-3.0/GF/Devel/Compute.hs
View File

@@ -21,6 +21,7 @@ import GF.Infra.Option
import GF.Data.Str
import GF.Grammar.PrGrammar
import GF.Infra.Modules
import GF.Grammar.Predef
import GF.Grammar.Macros
import GF.Grammar.Lookup
import GF.Grammar.Refresh
@@ -50,8 +51,8 @@ computeTermOpt rec gr = comput True where
comput full g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging
case t of
Q (IC "Predef") _ -> return t
Q p c -> look p c
Q p c | p == cPredef -> return t
| otherwise -> look p c
-- if computed do nothing
Computed t' -> return $ unComputed t'
@@ -89,7 +90,7 @@ computeTermOpt rec gr = comput True where
_ | not (null [() | FV _ <- as']) -> compApp g (mkApp h' as')
c@(QC _ _) -> do
return $ mkApp c as'
Q (IC "Predef") f -> do
Q mod f | mod == cPredef -> do
(t',b) <- appPredefined (mkApp h' as')
if b then return t' else comp g t'
@@ -446,8 +447,8 @@ computeTermOpt rec gr = comput True where
-- | argument variables cannot be glued
checkNoArgVars :: Term -> Err Term
checkNoArgVars t = case t of
Vr (IA _) -> Bad $ glueErrorMsg $ prt t
Vr (IAV _) -> Bad $ glueErrorMsg $ prt t
Vr (IA _ _) -> Bad $ glueErrorMsg $ prt t
Vr (IAV _ _ _) -> Bad $ glueErrorMsg $ prt t
_ -> composOp checkNoArgVars t
glueErrorMsg s =

2
src-3.0/GF/Devel/GFC.hs
View File

@@ -40,7 +40,7 @@ mainGFC xx = do
targetName :: Options -> CId -> String
targetName opts abs = case getOptVal opts (aOpt "target") of
Just n -> n
_ -> prIdent abs
_ -> prCId abs
targetNameGFCC :: Options -> CId -> FilePath
targetNameGFCC opts abs = targetName opts abs ++ ".gfcc"

5
src-3.0/GF/Devel/GFCCtoHaskell.hs
View File

@@ -175,15 +175,14 @@ fInstance m (cat,rules) =
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
hSkeleton :: GFCC -> (String,HSkeleton)
hSkeleton gr =
(pr (absname gr),
[(pr c, [(pr f, map pr cs) | (f, (cs,_)) <- fs]) |
(prCId (absname gr),
[(prCId c, [(prCId f, map prCId cs) | (f, (cs,_)) <- fs]) |
fs@((_, (_,c)):_) <- fns]
)
where
fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
valtyps (_, (_,x)) (_, (_,y)) = compare x y
valtypg (_, (_,x)) (_, (_,y)) = x == y
pr (CId c) = c
jty (f,(ty,_)) = (f,catSkeleton ty)
updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton

24
src-3.0/GF/Devel/GFCCtoJS.hs
View File

@@ -24,7 +24,7 @@ gfcc2js :: D.GFCC -> String
gfcc2js gfcc =
encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]]
where
n = D.printCId $ D.absname gfcc
n = prCId $ D.absname gfcc
as = D.abstract gfcc
cs = Map.assocs (D.concretes gfcc)
start = M.lookStartCat gfcc
@@ -36,16 +36,16 @@ abstract2js :: String -> D.Abstr -> JS.Expr
abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (D.funs ds))]
absdef2js :: (CId,(D.Type,D.Exp)) -> JS.Property
absdef2js (CId f,(typ,_)) =
let (args,CId cat) = M.catSkeleton typ in
JS.Prop (JS.StringPropName f) (new "Type" [JS.EArray [JS.EStr x | CId x <- args], JS.EStr cat])
absdef2js (f,(typ,_)) =
let (args,cat) = M.catSkeleton typ in
JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (new "Type" [JS.EArray [JS.EStr (prCId x) | x <- args], JS.EStr (prCId cat)])
concrete2js :: String -> String -> (CId,D.Concr) -> JS.Property
concrete2js start n (CId c, cnc) =
JS.Prop l (new "GFConcrete" ([(JS.EObj $ ((map (cncdef2js n c) ds) ++ litslins))] ++
concrete2js start n (c, cnc) =
JS.Prop l (new "GFConcrete" ([(JS.EObj $ ((map (cncdef2js n (prCId c)) ds) ++ litslins))] ++
maybe [] (parser2js start) (D.parser cnc)))
where
l = JS.StringPropName c
l = JS.IdentPropName (JS.Ident (prCId c))
ds = concatMap Map.assocs [D.lins cnc, D.opers cnc, D.lindefs cnc]
litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
@@ -53,7 +53,7 @@ concrete2js start n (CId c, cnc) =
cncdef2js :: String -> String -> (CId,D.Term) -> JS.Property
cncdef2js n l (CId f, t) = JS.Prop (JS.StringPropName f) (JS.EFun [children] [JS.SReturn (term2js n l t)])
cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)])
term2js :: String -> String -> D.Term -> JS.Expr
term2js n l t = f t
@@ -66,7 +66,7 @@ term2js n l t = f t
D.K t -> tokn2js t
D.V i -> JS.EIndex (JS.EVar children) (JS.EInt i)
D.C i -> new "Int" [JS.EInt i]
D.F (CId f) -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr f, JS.EVar children]
D.F f -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr (prCId f), JS.EVar children]
D.FV xs -> new "Variants" (map f xs)
D.W str x -> new "Suffix" [JS.EStr str, f x]
D.RP x y -> new "Rp" [f x, f y]
@@ -95,15 +95,15 @@ parser2js start p = [new "Parser" [JS.EStr start,
JS.EArray $ map frule2js (Array.elems (allRules p)),
JS.EObj $ map cats (Map.assocs (startupCats p))]]
where
cats (CId c,is) = JS.Prop (JS.StringPropName c) (JS.EArray (map JS.EInt is))
cats (c,is) = JS.Prop (JS.IdentPropName (JS.Ident (prCId c))) (JS.EArray (map JS.EInt is))
frule2js :: FRule -> JS.Expr
frule2js (FRule n args res lins) = new "Rule" [JS.EInt res, name2js n, JS.EArray (map JS.EInt args), lins2js lins]
name2js :: FName -> JS.Expr
name2js n = case n of
Name (CId "_") [p] -> fromProfile p
Name f ps -> new "FunApp" $ [JS.EStr $ prCId f, JS.EArray (map fromProfile ps)]
Name f [p] | f == wildCId -> fromProfile p
Name f ps -> new "FunApp" $ [JS.EStr $ prCId f, JS.EArray (map fromProfile ps)]
where
fromProfile :: Profile (SyntaxForest CId) -> JS.Expr
fromProfile (Unify []) = new "MetaVar" []

4
src-3.0/GF/Devel/GFI.hs
View File

@@ -5,7 +5,6 @@ import GF.Command.Importing
import GF.Command.Commands
import GF.GFCC.API
import GF.System.Arch (fetchCommand)
import GF.Devel.UseIO
import GF.Devel.Arch
import GF.Infra.Option ---- Haskell's option lib
@@ -21,7 +20,8 @@ mainGFI xx = do
loop :: GFEnv -> IO GFEnv
loop gfenv0 = do
let env = commandenv gfenv0
s <- fetchCommand (prompt env)
putStrFlush (prompt env)
s <- getLine
let gfenv = gfenv0 {history = s : history gfenv0}
case words s of

6
src-3.0/GF/Devel/Grammar/AppPredefined.hs
View File

@@ -53,13 +53,13 @@ typPredefined c@(IC f) = case f of
"plus" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "Int")
---- "read" -> (P : Type) -> Tok -> P
"show" -> return $ mkProds -- (P : PType) -> P -> Tok
([(identC "P",typePType),(wildIdent,Vr (identC "P"))],typeStr,[])
([(identC "P",typePType),(identW,Vr (identC "P"))],typeStr,[])
"toStr" -> return $ mkProds -- (L : Type) -> L -> Str
([(identC "L",typeType),(wildIdent,Vr (identC "L"))],typeStr,[])
([(identC "L",typeType),(identW,Vr (identC "L"))],typeStr,[])
"mapStr" ->
let ty = identC "L" in
return $ mkProds -- (L : Type) -> (Str -> Str) -> L -> L
([(ty,typeType),(wildIdent,mkFunType [typeStr] typeStr),(wildIdent,Vr ty)],Vr ty,[])
([(ty,typeType),(identW,mkFunType [typeStr] typeStr),(identW,Vr ty)],Vr ty,[])
"take" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
"tk" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
_ -> prtBad "unknown in Predef:" c

6
src-3.0/GF/Devel/Grammar/Macros.hs
View File

@@ -81,7 +81,7 @@ typeSkeleton typ = do
-- construct types and terms
mkFunType :: [Type] -> Type -> Type
mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt]) t -- nondep prod
mkFunType tt t = mkProd ([(identW, ty) | ty <- tt]) t -- nondep prod
mkApp :: Term -> [Term] -> Term
mkApp = foldl App
@@ -121,7 +121,7 @@ unzipR :: [Assign] -> ([Label],[Term])
unzipR r = (ls, map snd ts) where (ls,ts) = unzip r
mkDecl :: Term -> Decl
mkDecl typ = (wildIdent, typ)
mkDecl typ = (identW, typ)
mkLet :: [LocalDef] -> Term -> Term
mkLet defs t = foldr Let t defs
@@ -336,7 +336,7 @@ changeTableType co i = case i of
patt2term :: Patt -> Term
patt2term pt = case pt of
PV x -> Vr x
PW -> Vr wildIdent --- not parsable, should not occur
PW -> Vr identW --- not parsable, should not occur
PC c pp -> mkApp (Con c) (map patt2term pp)
PP p c pp -> mkApp (QC p c) (map patt2term pp)
PR r -> R [assign l (patt2term p) | (l,p) <- r]

2
src-3.0/GF/Devel/Grammar/PrGF.hs
View File

@@ -71,7 +71,7 @@ prModule :: SourceModule -> String
prModule = cprintTree . trModule
instance Print Judgement where
prt j = cprintTree $ trAnyDef (wildIdent, j)
prt j = cprintTree $ trAnyDef (identW, j)
---- prt_ = prExp
instance Print Term where

52
src-3.0/GF/Devel/GrammarToGFCC.hs
View File

@@ -1,3 +1,4 @@
{-# LANGUAGE PatternGuards #-}
module GF.Devel.GrammarToGFCC (prGrammar2gfcc,mkCanon2gfcc,addParsers) where
import GF.Devel.OptimizeGF (unshareModule)
@@ -9,6 +10,7 @@ import qualified GF.GFCC.Macros as CM
import qualified GF.GFCC.DataGFCC as C
import qualified GF.GFCC.DataGFCC as D
import GF.GFCC.CId
import GF.Grammar.Predef
import qualified GF.Grammar.Abstract as A
import qualified GF.Grammar.Macros as GM
--import qualified GF.Grammar.Compute as Compute
@@ -28,6 +30,7 @@ import GF.Text.UTF8
import Data.List
import Data.Char (isDigit,isSpace)
import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as BS
import Debug.Trace ----
-- when developing, swap commenting
@@ -46,7 +49,7 @@ mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.GFCC)
mkCanon2gfcc opts cnc gr =
(prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon abs) gr)
where
abs = err error id $ M.abstractOfConcrete gr (identC cnc)
abs = err error id $ M.abstractOfConcrete gr (identC (BS.pack cnc))
pars = mkParamLincat gr
-- Adds parsers for all concretes
@@ -67,9 +70,9 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
an = (i2i a)
cns = map (i2i . fst) cms
abs = D.Abstr aflags funs cats catfuns
gflags = Map.fromList [(CId fg,x) | Just x <- [getOptVal opts (aOpt fg)]]
gflags = Map.fromList [(mkCId fg,x) | Just x <- [getOptVal opts (aOpt fg)]]
where fg = "firstlang"
aflags = Map.fromList [(CId f,x) | Opt (f,[x]) <- M.flags abm]
aflags = Map.fromList [(mkCId f,x) | Opt (f,[x]) <- M.flags abm]
mkDef pty = case pty of
Yes t -> mkExp t
_ -> CM.primNotion
@@ -89,7 +92,7 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
(lang,D.Concr flags lins opers lincats lindefs printnames params fcfg)
where
js = tree2list (M.jments mo)
flags = Map.fromList [(CId f,x) | Opt (f,[x]) <- M.flags mo]
flags = Map.fromList [(mkCId f,x) | Opt (f,[x]) <- M.flags mo]
opers = Map.fromAscList [] -- opers will be created as optimization
utf = if elem (Opt ("coding",["utf8"])) (M.flags mo)
then D.convertStringsInTerm decodeUTF8 else id
@@ -107,7 +110,7 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
fcfg = Nothing
i2i :: Ident -> CId
i2i = CId . prIdent
i2i = CId . ident2bs
mkType :: A.Type -> C.Type
mkType t = case GM.typeForm t of
@@ -131,7 +134,7 @@ mkExp t = case t of
mkPatt p = uncurry CM.tree $ case p of
A.PP _ c ps -> (C.AC (i2i c), map mkPatt ps)
A.PV x -> (C.AV (i2i x), [])
A.PW -> (C.AV CM.wildCId, [])
A.PW -> (C.AV wildCId, [])
A.PInt i -> (C.AI i, [])
mkContext :: A.Context -> [C.Hypo]
@@ -139,10 +142,10 @@ mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps]
mkTerm :: Term -> C.Term
mkTerm tr = case tr of
Vr (IA (_,i)) -> C.V i
Vr (IAV (_,_,i)) -> C.V i
Vr (IC s) | isDigit (last s) ->
C.V (read (reverse (takeWhile (/='_') (reverse s))))
Vr (IA _ i) -> C.V i
Vr (IAV _ _ i) -> C.V i
Vr (IC s) | isDigit (BS.last s) ->
C.V ((read . BS.unpack . snd . BS.spanEnd isDigit) s)
---- from gf parser of gfc
EInt i -> C.C $ fromInteger i
R rs -> C.R [mkTerm t | (_, (_,t)) <- rs]
@@ -162,7 +165,7 @@ mkTerm tr = case tr of
C.K (C.KP (strings td) [C.Var (strings u) (strings v) | (u,v) <- tvs])
_ -> prtTrace tr $ C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- for debugging
where
mkLab (LIdent l) = case l of
mkLab (LIdent l) = case BS.unpack l of
'_':ds -> (read ds) :: Int
_ -> prtTrace tr $ 66663
strings t = case t of
@@ -182,8 +185,8 @@ mkCType t = case t of
Table pt vt -> case pt of
EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt
RecType rs -> mkCType $ foldr Table vt (map snd rs)
Sort "Str" -> C.S [] --- Str only
App (Q (IC "Predef") (IC "Ints")) (EInt i) -> C.C $ fromInteger i
Sort s | s == cStr -> C.S [] --- Str only
_ | Just i <- GM.isTypeInts t -> C.C $ fromInteger i
_ -> error $ "mkCType " ++ show t
-- encoding showable lincats (as in source gf) as terms
@@ -204,7 +207,7 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
p' <- mkPType p
v' <- mkPType v
return $ C.S [p',v']
Sort "Str" -> return $ C.S []
Sort s | s == cStr -> return $ C.S []
_ -> return $
C.FV $ map (kks . filter showable . prt_) $
errVal [] $ Look.allParamValues sgr typ
@@ -225,7 +228,7 @@ reorder abs cg = M.MGrammar $
adefs = sorted2tree $ sortIds $
predefADefs ++ Look.allOrigInfos cg abs
predefADefs =
[(IC c, AbsCat (Yes []) Nope) | c <- ["Float","Int","String"]]
[(c, AbsCat (Yes []) Nope) | c <- [cFloat,cInt,cString]]
aflags = nubFlags $
concat [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo]
@@ -238,10 +241,7 @@ reorder abs cg = M.MGrammar $
Just r <- [lookup i (M.allExtendSpecs cg la)]]
predefCDefs =
(IC "Int", CncCat (Yes Look.linTypeInt) Nope Nope) :
[(IC c, CncCat (Yes GM.defLinType) Nope Nope) |
---- lindef,printname
c <- ["Float","String"]]
[(c, CncCat (Yes GM.defLinType) Nope Nope) | c <- [cInt,cFloat,cString]]
sortIds = sortBy (\ (f,_) (g,_) -> compare f g)
nubFlags = nubBy (\ (Opt (f,_)) (Opt (g,_)) -> f == g)
@@ -369,13 +369,11 @@ paramValues cgr = (labels,untyps,typs) where
untyps =
Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs]
lincats =
[(IC "Int",[f | let RecType fs = Look.linTypeInt, f <- fs])] ++
[(IC cat,[(LIdent "s",GM.typeStr)]) | cat <- ["Float", "String"]] ++
[(cat,[f | let RecType fs = GM.defLinType, f <- fs]) | cat <- [cInt,cFloat, cString]] ++
reverse ---- TODO: really those lincats that are reached
---- reverse is enough to expel overshadowed ones...
[(cat,ls) | (_,(cat,CncCat (Yes ty) _ _)) <- jments,
RecType ls <- [unlockTy ty]]
---- [(cat,(unlockTyp ls)) | (_,(cat,CncCat (Yes (RecType ls)) _ _)) <- jments]
labels = Map.fromList $ concat
[((cat,[lab]),(typ,i)):
[((cat,[LVar v]),(typ,toInteger (mx + v))) | v <- [0,1]] ++ ---- 1 or 2 vars
@@ -449,7 +447,7 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
doVar tr = case getLab tr of
Ok (cat, lab) -> do
k <- readSTM >>= return . length
let tr' = Vr $ identC $ show k -----
let tr' = Vr $ identC $ (BS.pack (show k)) -----
let tyvs = case Map.lookup (cat,lab) labels of
Just (ty,_) -> case Map.lookup ty typs of
@@ -472,10 +470,10 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
-- this goes recursively into tables (ignored) and records (accumulated)
getLab tr = case tr of
Vr (IA (cat, _)) -> return (identC cat,[])
Vr (IAV (cat,_,_)) -> return (identC cat,[])
Vr (IA cat _) -> return (identC cat,[])
Vr (IAV cat _ _) -> return (identC cat,[])
Vr (IC s) -> return (identC cat,[]) where
cat = takeWhile (/='_') s ---- also to match IAVs; no _ in a cat tolerated
cat = BS.takeWhile (/='_') s ---- also to match IAVs; no _ in a cat tolerated
---- init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser
---- Vr _ -> error $ "getLab " ++ show tr
P p lab2 -> do
@@ -518,7 +516,7 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
mkCurrySel t p = S t p -- done properly in CheckGFCC
mkLab k = LIdent (("_" ++ show k))
mkLab k = LIdent (BS.pack ("_" ++ show k))
-- remove lock fields; in fact, any empty records and record types
unlock = filter notlock where

90
src-3.0/GF/Devel/Optimize.hs
View File

@@ -1,3 +1,4 @@
{-# LANGUAGE PatternGuards #-}
----------------------------------------------------------------------
-- |
-- Module : Optimize
@@ -20,6 +21,7 @@ import GF.Infra.Modules
import GF.Grammar.PrGrammar
import GF.Grammar.Macros
import GF.Grammar.Lookup
import GF.Grammar.Predef
import GF.Grammar.Refresh
import GF.Devel.Compute
import GF.Compile.BackOpt
@@ -128,9 +130,9 @@ evalCncInfo opts gr cnc abs (c,info) = do
CncCat ptyp pde ppr -> do
pde' <- case (ptyp,pde) of
(Yes typ, Yes de) ->
liftM yes $ pEval ([(strVar, typeStr)], typ) de
liftM yes $ pEval ([(varStr, typeStr)], typ) de
(Yes typ, Nope) ->
liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(strVar, typeStr)],typ)
liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(varStr, typeStr)],typ)
(May b, Nope) ->
return $ May b
_ -> return pde -- indirection
@@ -161,72 +163,20 @@ partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do
let vars = map fst context
args = map Vr vars
subst = [(v, Vr v) | v <- vars]
trm1 = mkApp trm args
trm3 <- if globalTable
then etaExpand subst trm1 >>= outCase subst
else etaExpand subst trm1
trm1 = mkApp trm args
trm2 <- computeTerm gr subst trm1
trm3 <- if rightType trm2
then computeTerm gr subst trm2
else recordExpand val trm2 >>= computeTerm gr subst
return $ mkAbs vars trm3
where
-- don't eta expand records of right length (correct by type checking)
rightType (R rs) = case val of
RecType ts -> length rs == length ts
_ -> False
rightType _ = False
where
globalTable = oElem showAll opts --- i -all
comp g t = {- refreshTerm t >>= -} computeTerm gr g t
etaExpand su t = do
t' <- comp su t
case t' of
R _ | rightType t' -> comp su t' --- return t' wo noexpand...
_ -> recordExpand val t' >>= comp su
-- don't eta expand records of right length (correct by type checking)
rightType t = case (t,val) of
(R rs, RecType ts) -> length rs == length ts
_ -> False
outCase subst t = do
pts <- getParams context
let (args,ptyps) = unzip $ filter (flip occur t . fst) pts
if null args
then return t
else do
let argtyp = RecType $ tuple2recordType ptyps
let pvars = map (Vr . zIdent . prt) args -- gets eliminated
patt <- term2patt $ R $ tuple2record $ pvars
let t' = replace (zip args pvars) t
t1 <- comp subst $ T (TTyped argtyp) [(patt, t')]
return $ S t1 $ R $ tuple2record args
--- notice: this assumes that all lin types follow the "old JFP style"
getParams = liftM concat . mapM getParam
getParam (argv,RecType rs) = return
[(P (Vr argv) lab, ptyp) | (lab,ptyp) <- rs, not (isLinLabel lab)]
---getParam (_,ty) | ty==typeStr = return [] --- in lindef
getParam (av,ty) =
Bad ("record type expected not" +++ prt ty +++ "for" +++ prt av)
--- all lin types are rec types
replace :: [(Term,Term)] -> Term -> Term
replace reps trm = case trm of
-- this is the important case
P _ _ -> maybe trm id $ lookup trm reps
_ -> composSafeOp (replace reps) trm
occur t trm = case trm of
-- this is the important case
P _ _ -> t == trm
S x y -> occur t y || occur t x
App f x -> occur t x || occur t f
Abs _ f -> occur t f
R rs -> any (occur t) (map (snd . snd) rs)
T _ cs -> any (occur t) (map snd cs)
C x y -> occur t x || occur t y
Glue x y -> occur t x || occur t y
ExtR x y -> occur t x || occur t y
FV ts -> any (occur t) ts
V _ ts -> any (occur t) ts
Let (_,(_,x)) y -> occur t x || occur t y
_ -> False
-- here we must be careful not to reduce
@@ -246,8 +196,8 @@ recordExpand typ trm = case unComputed typ of
mkLinDefault :: SourceGrammar -> Type -> Err Term
mkLinDefault gr typ = do
case unComputed typ of
RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign)
_ -> liftM (Abs strVar) $ mkDefField typ
RecType lts -> mapPairsM mkDefField lts >>= (return . Abs varStr . R . mkAssign)
_ -> liftM (Abs varStr) $ mkDefField typ
---- _ -> prtBad "linearization type must be a record type, not" typ
where
mkDefField typ = case unComputed typ of
@@ -255,13 +205,13 @@ mkLinDefault gr typ = do
t' <- mkDefField t
let T _ cs = mkWildCases t'
return $ T (TWild p) cs
Sort "Str" -> return $ Vr strVar
QC q p -> lookupFirstTag gr q p
Sort s | s == cStr -> return $ Vr varStr
QC q p -> lookupFirstTag gr q p
RecType r -> do
let (ls,ts) = unzip r
ts' <- mapM mkDefField ts
return $ R $ [assign l t | (l,t) <- zip ls ts']
_ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val
_ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
_ -> prtBad "linearization type field cannot be" typ
-- | Form the printname: if given, compute. If not, use the computed

17
src-3.0/GF/Devel/OptimizeGF.hs
View File

@@ -30,6 +30,7 @@ import GF.Data.Operations
import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as BS
import Data.List
optModule :: (Ident, SourceModInfo) -> (Ident, SourceModInfo)
@@ -88,7 +89,7 @@ factor c i t = case t of
--- we hope this will be fresh and don't check... in GFC would be safe
qqIdent c i = identC ("q_" ++ prt c ++ "__" ++ show i)
qqIdent c i = identC (BS.pack ("q_" ++ prt c ++ "__" ++ show i))
-- we need to replace subterms
@@ -190,7 +191,7 @@ unsubexpModule mo@(i,m) = case m of
ResOper pty (Yes t) -> [(c, ResOper pty (Yes (unparTerm t)))]
_ -> [(c,info)]
unparTerm t = case t of
Q m c@(IC ('A':'\'':'\'':_)) -> --- name convention of subexp opers
Q m c | isOperIdent c -> --- name convention of subexp opers
errVal t $ liftM unparTerm $ lookupResDef gr m c
_ -> C.composSafeOp unparTerm t
gr = M.MGrammar [mo]
@@ -217,12 +218,12 @@ addSubexpConsts mo tree lins = do
return (f,ResOper ty (Yes trm'))
_ -> return (f,def)
recomp f t = case Map.lookup t tree of
Just (_,id) | ident id /= f -> return $ Q mo (ident id)
Just (_,id) | operIdent id /= f -> return $ Q mo (operIdent id)
_ -> C.composOp (recomp f) t
list = Map.toList tree
oper id trm = (ident id, ResOper (Yes (EInt 8)) (Yes trm))
oper id trm = (operIdent id, ResOper (Yes (EInt 8)) (Yes trm))
--- impossible type encoding generated opers
getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
@@ -266,6 +267,10 @@ collectSubterms mo t = case t of
writeSTM (Map.insert t (count,id) ts, next)
return t --- only because of composOp
ident :: Int -> Ident
ident i = identC ("A''" ++ show i) ---
operIdent :: Int -> Ident
operIdent i = identC (operPrefix `BS.append` (BS.pack (show i))) ---
isOperIdent :: Ident -> Bool
isOperIdent id = BS.isPrefixOf operPrefix (ident2bs id)
operPrefix = BS.pack ("A''")

2
src-3.0/GF/Devel/ReadFiles.hs
View File

@@ -185,7 +185,7 @@ importsOfModule (MModule _ typ body) = modType typ (modBody body [])
opens NoOpens xs = xs
opens (OpenIn os) xs = foldr open xs os
modName (PIdent (_,s)) = s
modName (PIdent (_,s)) = BS.unpack s
-- | options can be passed to the compiler by comments in @--#@, in the main file

26
src-3.0/GF/Devel/TC.hs
View File

@@ -22,6 +22,7 @@ module GF.Devel.TC (AExp(..),
) where
import GF.Data.Operations
import GF.Grammar.Predef
import GF.Grammar.Abstract
import GF.Devel.AbsCompute
@@ -145,10 +146,9 @@ checkInferExp th tenv@(k,_,_) e typ = do
inferExp :: Theory -> TCEnv -> Exp -> Err (AExp, Val, [(Val,Val)])
inferExp th tenv@(k,rho,gamma) e = case e of
Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
Q m c
| m == cPredefAbs && (elem c (map identC ["Int","String","Float"])) ->
return (ACn (m,c) vType, vType, [])
| otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c)
Q m c | m == cPredefAbs && isPredefCat c
-> return (ACn (m,c) vType, vType, [])
| otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c)
QC m c -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) ----
EInt i -> return (AInt i, valAbsInt, [])
EFloat i -> return (AFloat i, valAbsFloat, [])
@@ -164,12 +164,6 @@ inferExp th tenv@(k,rho,gamma) e = case e of
return $ (AApp f' a' b', b', csf ++ csa)
_ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ
_ -> prtBad "cannot infer type of expression" e
where
predefAbs c s = case c of
IC "Int" -> return $ const $ Q cPredefAbs cInt
IC "Float" -> return $ const $ Q cPredefAbs cFloat
IC "String" -> return $ const $ Q cPredefAbs cString
_ -> Bad s
checkEqs :: Theory -> TCEnv -> (Fun,Trm) -> Val -> Err [(Val,Val)]
checkEqs th tenv@(k,rho,gamma) (fun@(m,f),def) val = case def of
@@ -188,9 +182,9 @@ checkEqs th tenv@(k,rho,gamma) (fun@(m,f),def) val = case def of
(_,cs2) <- errIn (show bds) $ checkExp th tenv' df typ
return $ (cs1 ++ cs2)
p2t p (ps,i,g) = case p of
PW -> (meta (MetaSymb i) : ps, i+1, g)
PV IW -> (meta (MetaSymb i) : ps, i+1, g)
PV x -> (meta (MetaSymb i) : ps, i+1,upd x i g)
PW -> (Meta (MetaSymb i) : ps, i+1, g)
PV IW -> (Meta (MetaSymb i) : ps, i+1, g)
PV x -> (Meta (MetaSymb i) : ps, i+1,upd x i g)
PString s -> ( K s : ps, i, g)
PInt n -> (EInt n : ps, i, g)
PFloat n -> (EFloat n : ps, i, g)
@@ -238,9 +232,9 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
ps2ts k = foldr p2t ([],0,[],k)
p2t p (ps,i,g,k) = case p of
PW -> (meta (MetaSymb i) : ps, i+1,g,k)
PV IW -> (meta (MetaSymb i) : ps, i+1,g,k)
PV x -> (vr x : ps, i, upd x k g,k+1)
PW -> (Meta (MetaSymb i) : ps, i+1,g,k)
PV IW -> (Meta (MetaSymb i) : ps, i+1,g,k)
PV x -> (Vr x : ps, i, upd x k g,k+1)
PString s -> (K s : ps, i, g, k)
PInt n -> (EInt n : ps, i, g, k)
PFloat n -> (EFloat n : ps, i, g, k)