GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki 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 e8bbd458cb
commit 314f5cc5e7
65 changed files with 6275 additions and 6432 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src-3.0/GF/CF/CFtoGrammar.hs
View File

@@ -46,7 +46,7 @@ cf2rule :: CFRule -> ((Ident,Info),(Ident,Info))
cf2rule (fun, (cat, items)) = (def,ldef) where
f = cfFun2Ident fun
def = (f, AbsFun (yes (mkProd (args', Cn (cfCat2Ident cat), []))) nope)
args0 = zip (map (mkIdent "x") [0..]) items
args0 = zip (map (identV "x") [0..]) items
args = [(v, Cn (cfCat2Ident c)) | (v, CFNonterm c) <- args0]
args' = [(zIdent "_", Cn (cfCat2Ident c)) | (_, CFNonterm c) <- args0]
ldef = (f, CncFun

5
src-3.0/GF/Canon/GFC.hs
View File

@@ -39,6 +39,7 @@ import GF.Data.Operations
import qualified GF.Infra.Modules as M
import Data.Char
import qualified Data.ByteString.Char8 as BS
import Control.Arrow (first)
type Context = [(Ident,Exp)]
@@ -73,7 +74,7 @@ mapInfoTerms f i = case i of
_ -> i
setFlag :: String -> String -> [Flag] -> [Flag]
setFlag n v fs = flagCanon n v : [f | f@(Flg (IC n') _) <- fs, n' /= n]
setFlag n v fs = flagCanon n v : [f | f@(Flg (IC n') _) <- fs, n' /= BS.pack n]
flagIncomplete :: Flag
flagIncomplete = flagCanon "incomplete" "true"
@@ -86,7 +87,7 @@ hasFlagCanon f (_,M.ModMod mo) = elem f $ M.flags mo
hasFlagCanon f _ = True ---- safe, useless
flagCanon :: String -> String -> Flag
flagCanon f v = Flg (identC f) (identC v)
flagCanon f v = Flg (identC (BS.pack f)) (identC (BS.pack v))
-- for Ha-Jo 20/2/2005

9
src-3.0/GF/Command/Commands.hs
View File

@@ -12,6 +12,7 @@ module GF.Command.Commands (
import GF.Command.AbsGFShell hiding (Tree)
import GF.Command.PPrTree
import GF.Command.ParGFShell
import GF.GFCC.CId
import GF.GFCC.ShowLinearize
import GF.GFCC.API
import GF.GFCC.Macros
@@ -131,10 +132,10 @@ allCommands mgr = Map.fromAscList [
optLin opts t = unlines [linea lang t | lang <- optLangs opts] where
linea lang = case opts of
_ | isOpt "all" opts -> allLinearize gr (cid lang)
_ | isOpt "table" opts -> tableLinearize gr (cid lang)
_ | isOpt "term" opts -> termLinearize gr (cid lang)
_ | isOpt "record" opts -> recordLinearize gr (cid lang)
_ | isOpt "all" opts -> allLinearize gr (mkCId lang)
_ | isOpt "table" opts -> tableLinearize gr (mkCId lang)
_ | isOpt "term" opts -> termLinearize gr (mkCId lang)
_ | isOpt "record" opts -> recordLinearize gr (mkCId lang)
_ -> linearize mgr lang

4
src-3.0/GF/Command/PPrTree.hs
View File

@@ -21,7 +21,7 @@ tree2exp t = case t of
TStr s -> tree (AS s) []
TFloat d -> tree (AF d) []
where
i2i (Ident s) = CId s
i2i (Ident s) = mkCId s
prExp :: Exp -> String
prExp = printTree . exp2tree
@@ -36,4 +36,4 @@ exp2tree (DTr xs at ts) = tabs (map i4i xs) (tapp at (map exp2tree ts))
tapp (AS i) [] = TStr i
tapp (AF i) [] = TFloat i
tapp (AM i) [] = TId (Ident "?") ----
i4i (CId s) = Ident s
i4i s = Ident (prCId s)

2
src-3.0/GF/Compile/API.hs
View File

@@ -10,7 +10,7 @@ import GF.Devel.UseIO
-- | Compiles a number of source files and builds a 'GFCC' structure for them.
compileToGFCC :: Options -> [FilePath] -> IOE GFCC
compileToGFCC opts fs =
compileToGFCC opts fs =
do gr <- batchCompile opts fs
let name = justModuleName (last fs)
gc1 <- putPointE opts "linking ... " $

3
src-3.0/GF/Compile/BackOpt.hs
View File

@@ -24,6 +24,7 @@ import GF.Grammar.PrGrammar (prt)
import GF.Data.Operations
import Data.List
import qualified GF.Infra.Modules as M
import qualified Data.ByteString.Char8 as BS
type OptSpec = [Integer] ---
@@ -110,7 +111,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

2
src-3.0/GF/Compile/Flatten.hs
View File

@@ -42,7 +42,7 @@ mkRules conf f t = (fun f ty, lin f (takeWhile (/=':') t)) where
args = mkArgs conf ts
ty = concat [a ++ " -> " | a <- map snd args] ++ val
(ts,val) = let tt = lexTerm t in (init tt,last tt)
--- f = mkIdent t
--- f = identV t
fun c a = unwords [" fun", c, ":",a,";"]
lin c a = unwords $ [" lin", c] ++ map fst args ++ ["=",a,";"]

8
src-3.0/GF/Compile/Optimize.hs
View File

@@ -130,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
@@ -248,7 +248,7 @@ 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)
RecType lts -> mapPairsM mkDefField lts >>= (return . Abs varStr . R . mkAssign)
_ -> prtBad "linearization type must be a record type, not" typ
where
mkDefField typ = case unComputed typ of
@@ -256,7 +256,7 @@ mkLinDefault gr typ = do
t' <- mkDefField t
let T _ cs = mkWildCases t'
return $ T (TWild p) cs
Sort "Str" -> return $ Vr strVar
Sort "Str" -> return $ Vr varStr
QC q p -> lookupFirstTag gr q p
RecType r -> do
let (ls,ts) = unzip r

3
src-3.0/GF/Compile/RemoveLiT.hs
View File

@@ -23,6 +23,7 @@ import GF.Infra.Ident
import GF.Infra.Modules
import GF.Grammar.Macros
import GF.Grammar.Lookup
import GF.Grammar.Predef
import GF.Data.Operations
@@ -60,4 +61,4 @@ remlTerm gr trm = case trm of
look c = err (const $ return defLinType) return $ lookupLincat gr m c
m = case [cnc | (cnc,ModMod m) <- modules gr, isModCnc m] of
cnc:_ -> cnc -- actually there is always exactly one
_ -> zIdent "CNC"
_ -> cCNC

10
src-3.0/GF/Compile/Rename.hs
View File

@@ -29,6 +29,7 @@ module GF.Compile.Rename (renameGrammar,
import GF.Grammar.Grammar
import GF.Grammar.Values
import GF.Grammar.Predef
import GF.Infra.Modules
import GF.Infra.Ident
import GF.Grammar.Macros
@@ -90,11 +91,9 @@ renameIdentTerm env@(act,imps) t =
[(m, st) | (OSimple _ m, st) <- imps] -- qualif is always possible
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
predefAbs c s = case c of
IC "Int" -> return $ Q cPredefAbs cInt
IC "Float" -> return $ Q cPredefAbs cFloat
IC "String" -> return $ Q cPredefAbs cString
_ -> Bad s
predefAbs c s
| isPredefCat c = return $ Q cPredefAbs c
| otherwise = Bad s
ident alt c = case lookupTree prt c act of
Ok f -> return $ f c
@@ -104,7 +103,6 @@ renameIdentTerm env@(act,imps) t =
fs -> case nub [f c | f <- fs] of
[tr] -> return tr
ts@(t:_) -> trace ("WARNING: conflict" +++ unwords (map prt ts)) (return t)
---- ts -> return $ Strs $ (cnIC "#conflict") : reverse ts
-- a warning will be generated in CheckGrammar, and the head returned
-- in next V:
-- Bad $ "conflicting imports:" +++ unwords (map prt ts)

23
src-3.0/GF/Conversion/SimpleToFCFG.hs
View File

@@ -33,6 +33,7 @@ import GF.Data.Utilities (updateNthM, sortNub)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.List as List
import qualified Data.ByteString.Char8 as BS
import Data.Array
import Data.Maybe
@@ -81,24 +82,24 @@ expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
modifyRec f (R xs) = R (f xs)
modifyRec _ t = error $ "Not a record: " ++ show t
varCat = CId "_Var"
varCat = mkCId "_Var"
catName :: (Int,CId) -> CId
catName (0,c) = c
catName (n,CId c) = CId ("_" ++ show n ++ c)
catName (n,c) = mkCId ("_" ++ show n ++ prt c)
funName :: (Int,CId) -> CId
funName (n,CId c) = CId ("__" ++ show n ++ c)
funName (n,c) = mkCId ("__" ++ show n ++ prt c)
varFunName :: CId -> CId
varFunName (CId c) = CId ("_Var_" ++ c)
varFunName c = mkCId ("_Var_" ++ prt c)
-- replaces __NCat with _B and _Var_Cat with _.
-- the temporary names are just there to avoid name collisions.
fixHoasFuns :: FGrammar -> FGrammar
fixHoasFuns (rs, cs) = ([FRule (fixName n) args cat lins | FRule n args cat lins <- rs], cs)
where fixName (Name (CId ('_':'_':_)) p) = Name (CId "_B") p
fixName (Name (CId n) p) | "_Var_" `List.isPrefixOf` n = Name wildCId p
where fixName (Name (CId n) p) | BS.pack "__" `BS.isPrefixOf` n = Name (mkCId "_B") p
| BS.pack "_Var_" `BS.isPrefixOf` n = Name wildCId p
fixName n = n
convert :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> FGrammar
@@ -291,10 +292,10 @@ data ProtoFCat = PFCat CId [FPath] [(FPath,FIndex)]
protoFCat :: CId -> ProtoFCat
protoFCat cat = PFCat cat [] []
emptyFRulesEnv = FRulesEnv 0 (ins fcatString (CId "String") [[0]] [] $
ins fcatInt (CId "Int") [[0]] [] $
ins fcatFloat (CId "Float") [[0]] [] $
ins fcatVar (CId "_Var") [[0]] [] $
emptyFRulesEnv = FRulesEnv 0 (ins fcatString (mkCId "String") [[0]] [] $
ins fcatInt (mkCId "Int") [[0]] [] $
ins fcatFloat (mkCId "Float") [[0]] [] $
ins fcatVar (mkCId "_Var") [[0]] [] $
Map.empty) []
where
ins fcat cat rcs tcs fcatSet =
@@ -340,7 +341,7 @@ genFCatArg cnc_defs ctype env@(FRulesEnv last_id fcatSet rules) (PFCat cat rcs t
(either_fcat,last_id1,tmap1,rules1)
= foldBM (\tcs st (either_fcat,last_id,tmap,rules) ->
let (last_id1,tmap1,fcat_arg) = addArg tcs last_id tmap
rule = FRule (Name (CId "_") [Unify [0]]) [fcat_arg] fcat
rule = FRule (Name wildCId [Unify [0]]) [fcat_arg] fcat
(listArray (0,length rcs-1) [listArray (0,0) [FSymCat fcat_arg lbl 0] | lbl <- [0..length rcs-1]])
in if st
then (Right fcat, last_id1,tmap1,rule:rules)

2
src-3.0/GF/Conversion/Types.hs
View File

@@ -89,7 +89,7 @@ sameECat :: ECat -> ECat -> Bool
sameECat ec1 ec2 = ecat2scat ec1 == ecat2scat ec2
coercionName :: Name
coercionName = Name Ident.wildIdent [Unify [0]]
coercionName = Name Ident.identW [Unify [0]]
isCoercion :: Name -> Bool
isCoercion (Name fun [Unify [0]]) = Ident.isWildIdent fun

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)

5
src-3.0/GF/Formalism/FCFG.hs
View File

@@ -41,7 +41,6 @@ import GF.Formalism.Utilities
import qualified GF.GFCC.CId as AbsGFCC
import GF.Infra.PrintClass
------------------------------------------------------------
-- Token
type FToken = String
@@ -72,7 +71,7 @@ data FSymbol
type FName = NameProfile AbsGFCC.CId
isCoercionF :: FName -> Bool
isCoercionF (Name fun [Unify [0]]) = fun == AbsGFCC.CId "_"
isCoercionF (Name fun [Unify [0]]) = fun == AbsGFCC.wildCId
isCoercionF _ = False
@@ -87,7 +86,7 @@ data FRule = FRule FName [FCat] FCat (Array FIndex (Array FPointPos FSymbol)
-- pretty-printing
instance Print AbsGFCC.CId where
prt (AbsGFCC.CId s) = s
prt = AbsGFCC.prCId
instance Print FSymbol where
prt (FSymCat c l n) = "($" ++ prt n ++ "!" ++ prt l ++ ")"

2
src-3.0/GF/Formalism/SimpleGFC.hs
View File

@@ -27,7 +27,7 @@ type Var = Ident.Ident
type Label = AbsGFC.Label
anyVar :: Var
anyVar = Ident.wildIdent
anyVar = Ident.identW
----------------------------------------------------------------------
-- * simple GFC

21
src-3.0/GF/GFCC/API.hs
View File

@@ -84,12 +84,12 @@ file2gfcc f = do
g <- parseGrammar s
return $ toGFCC g
linearize mgr lang = GF.GFCC.Linearize.linearize (gfcc mgr) (CId lang)
linearize mgr lang = GF.GFCC.Linearize.linearize (gfcc mgr) (mkCId lang)
parse mgr lang cat s =
case lookParser (gfcc mgr) (CId lang) of
case lookParser (gfcc mgr) (mkCId lang) of
Nothing -> error "no parser"
Just pinfo -> case parseFCF "bottomup" pinfo (CId cat) (words s) of
Just pinfo -> case parseFCF "bottomup" pinfo (mkCId cat) (words s) of
Ok x -> x
Bad s -> error s
@@ -104,23 +104,20 @@ parseAllLang mgr cat s =
generateRandom mgr cat = do
gen <- newStdGen
return $ genRandom gen (gfcc mgr) (CId cat)
return $ genRandom gen (gfcc mgr) (mkCId cat)
generateAll mgr cat = generate (gfcc mgr) (CId cat) Nothing
generateAllDepth mgr cat = generate (gfcc mgr) (CId cat)
generateAll mgr cat = generate (gfcc mgr) (mkCId cat) Nothing
generateAllDepth mgr cat = generate (gfcc mgr) (mkCId cat)
readTree _ = pTree
showTree = prExp
prIdent :: CId -> String
prIdent (CId s) = s
abstractName mgr = prCId (absname (gfcc mgr))
abstractName mgr = prIdent (absname (gfcc mgr))
languages mgr = [prCId l | l <- cncnames (gfcc mgr)]
languages mgr = [l | CId l <- cncnames (gfcc mgr)]
categories mgr = [c | CId c <- Map.keys (cats (abstract (gfcc mgr)))]
categories mgr = [prCId c | c <- Map.keys (cats (abstract (gfcc mgr)))]
startCat mgr = lookStartCat (gfcc mgr)

23
src-3.0/GF/GFCC/CId.hs
View File

@@ -1,14 +1,15 @@
module GF.GFCC.CId (
module GF.GFCC.Raw.AbsGFCCRaw,
prCId,
cId
) where
module GF.GFCC.CId (CId(..), wildCId, mkCId, prCId) where
import GF.GFCC.Raw.AbsGFCCRaw (CId(CId))
import GF.Infra.PrintClass
import Data.ByteString.Char8 as BS
newtype CId = CId BS.ByteString deriving (Eq,Ord,Show)
wildCId :: CId
wildCId = CId (BS.singleton '_')
mkCId :: String -> CId
mkCId s = CId (BS.pack s)
prCId :: CId -> String
prCId (CId s) = s
cId :: String -> CId
cId = CId
prCId (CId x) = BS.unpack x

4
src-3.0/GF/GFCC/CheckGFCC.hs
View File

@@ -45,7 +45,7 @@ labelBoolErr ms iob = do
checkConcrete :: GFCC -> (CId,Concr) -> Err ((CId,Concr),Bool)
checkConcrete gfcc (lang,cnc) =
labelBoolErr ("happened in language " ++ printCId lang) $ do
labelBoolErr ("happened in language " ++ prCId lang) $ do
(rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip
return ((lang,cnc{lins = Map.fromAscList rs}),and bs)
where
@@ -53,7 +53,7 @@ checkConcrete gfcc (lang,cnc) =
checkLin :: GFCC -> CId -> (CId,Term) -> Err ((CId,Term),Bool)
checkLin gfcc lang (f,t) =
labelBoolErr ("happened in function " ++ printCId f) $ do
labelBoolErr ("happened in function " ++ prCId f) $ do
(t',b) <- checkTerm (lintype gfcc lang f) t --- $ inline gfcc lang t
return ((f,t'),b)

17
src-3.0/GF/GFCC/DataGFCC.hs
View File

@@ -1,6 +1,7 @@
module GF.GFCC.DataGFCC where
import GF.GFCC.CId
import GF.Infra.PrintClass(prt)
import GF.Infra.CompactPrint
import GF.Text.UTF8
import GF.Formalism.FCFG
@@ -90,21 +91,17 @@ data Equation =
statGFCC :: GFCC -> String
statGFCC gfcc = unlines [
"Abstract\t" ++ pr (absname gfcc),
"Concretes\t" ++ unwords (lmap pr (cncnames gfcc)),
"Categories\t" ++ unwords (lmap pr (keys (cats (abstract gfcc))))
"Abstract\t" ++ prt (absname gfcc),
"Concretes\t" ++ unwords (lmap prt (cncnames gfcc)),
"Categories\t" ++ unwords (lmap prt (keys (cats (abstract gfcc))))
]
where pr (CId s) = s
printCId :: CId -> String
printCId (CId s) = s
-- merge two GFCCs; fails is differens absnames; priority to second arg
unionGFCC :: GFCC -> GFCC -> GFCC
unionGFCC one two = case absname one of
CId "" -> two -- extending empty grammar
n | n == absname two -> one { -- extending grammar with same abstract
n | n == wildCId -> two -- extending empty grammar
| n == absname two -> one { -- extending grammar with same abstract
concretes = Data.Map.union (concretes two) (concretes one),
cncnames = Data.List.union (cncnames two) (cncnames one)
}
@@ -112,7 +109,7 @@ unionGFCC one two = case absname one of
emptyGFCC :: GFCC
emptyGFCC = GFCC {
absname = CId "",
absname = wildCId,
cncnames = [] ,
gflags = empty,
abstract = error "empty grammar, no abstract",

4
src-3.0/GF/GFCC/Generate.hs
View File

@@ -36,8 +36,8 @@ genRandom gen gfcc cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where
(genTrees ds2 cat) -- else (drop k ds)
genTree rs = gett rs where
gett ds (CId "String") = (tree (AS "foo") [], 1)
gett ds (CId "Int") = (tree (AI 12345) [], 1)
gett ds cid | cid == mkCId "String" = (tree (AS "foo") [], 1)
gett ds cid | cid == mkCId "Int" = (tree (AI 12345) [], 1)
gett [] _ = (tree (AS "TIMEOUT") [], 1) ----
gett ds cat = case fns cat of
[] -> (tree (AM 0) [],1)

7
src-3.0/GF/GFCC/Linearize.hs
View File

@@ -3,6 +3,7 @@ module GF.GFCC.Linearize where
import GF.GFCC.Macros
import GF.GFCC.DataGFCC
import GF.GFCC.CId
import GF.Infra.PrintClass
import Data.Map
import Data.List
@@ -35,7 +36,7 @@ linExp mcfg lang tree@(DTr xs at trees) =
--- [C lst, kks (show i), C size] where
--- lst = mod (fromInteger i) 10 ; size = if i < 10 then 0 else 1
AF d -> R [kks (show d)]
AV x -> TM (prCId x)
AV x -> TM (prt x)
AM i -> TM (show i)
where
lin = linExp mcfg lang
@@ -44,8 +45,8 @@ linExp mcfg lang tree@(DTr xs at trees) =
addB t
| Data.List.null xs = t
| otherwise = case t of
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
TM s -> R $ t : (Data.List.map (kks . prCId) xs)
R ts -> R $ ts ++ (Data.List.map (kks . prt) xs)
TM s -> R $ t : (Data.List.map (kks . prt) xs)
compute :: GFCC -> CId -> [Term] -> Term -> Term
compute mcfg lang args = comp where

12
src-3.0/GF/GFCC/Macros.hs
View File

@@ -4,7 +4,7 @@ import GF.GFCC.CId
import GF.GFCC.DataGFCC
import GF.Formalism.FCFG (FGrammar)
import GF.Parsing.FCFG.PInfo (FCFPInfo, fcfPInfoToFGrammar)
----import GF.GFCC.PrintGFCC
import GF.Infra.PrintClass
import Control.Monad
import Data.Map
import Data.Maybe
@@ -39,7 +39,7 @@ lookFCFG :: GFCC -> CId -> Maybe FGrammar
lookFCFG gfcc lang = fmap fcfPInfoToFGrammar $ lookParser gfcc lang
lookStartCat :: GFCC -> String
lookStartCat gfcc = fromMaybe "S" $ msum $ Data.List.map (Data.Map.lookup (CId "startcat"))
lookStartCat gfcc = fromMaybe "S" $ msum $ Data.List.map (Data.Map.lookup (mkCId "startcat"))
[gflags gfcc, aflags (abstract gfcc)]
lookGlobalFlag :: GFCC -> CId -> String
@@ -87,12 +87,6 @@ contextLength :: Type -> Int
contextLength ty = case ty of
DTyp hyps _ _ -> length hyps
cid :: String -> CId
cid = CId
wildCId :: CId
wildCId = cid "_"
exp0 :: Exp
exp0 = tree (AM 0) []
@@ -100,7 +94,7 @@ primNotion :: Exp
primNotion = EEq []
term0 :: CId -> Term
term0 = TM . prCId
term0 = TM . prt
tm0 :: Term
tm0 = TM "?"

2
src-3.0/GF/GFCC/OptimizeGFCC.hs
View File

@@ -75,7 +75,7 @@ addSubexpConsts tree cnc = cnc {
W s t -> W s (recomp f t)
P t p -> P (recomp f t) (recomp f p)
_ -> t
fid n = CId $ "_" ++ show n
fid n = mkCId $ "_" ++ show n
rec field = Map.fromAscList [(f,recomp f trm) | (f,trm) <- Map.assocs (field cnc)]

5
src-3.0/GF/GFCC/Raw/AbsGFCCRaw.hs
View File

@@ -1,14 +1,11 @@
module GF.GFCC.Raw.AbsGFCCRaw where
-- Haskell module generated by the BNF converter
newtype CId = CId String deriving (Eq,Ord,Show)
data Grammar =
Grm [RExp]
deriving (Eq,Ord,Show)
data RExp =
App CId [RExp]
App String [RExp]
| AInt Integer
| AStr String
| AFlt Double

197
src-3.0/GF/GFCC/Raw/ConvertGFCC.hs
View File

@@ -1,8 +1,10 @@
module GF.GFCC.Raw.ConvertGFCC (toGFCC,fromGFCC) where
import GF.GFCC.CId
import GF.GFCC.DataGFCC
import GF.GFCC.Raw.AbsGFCCRaw
import GF.Infra.PrintClass
import GF.Data.Assoc
import GF.Formalism.FCFG
import GF.Formalism.Utilities (NameProfile(..), Profile(..), SyntaxForest(..))
@@ -18,29 +20,29 @@ pgfMajorVersion, pgfMinorVersion :: Integer
toGFCC :: Grammar -> GFCC
toGFCC (Grm [
App (CId "pgf") (AInt v1 : AInt v2 : App a []:cs),
App (CId "flags") gfs,
App "pgf" (AInt v1 : AInt v2 : App a []:cs),
App "flags" gfs,
ab@(
App (CId "abstract") [
App (CId "fun") fs,
App (CId "cat") cts
App "abstract" [
App "fun" fs,
App "cat" cts
]),
App (CId "concrete") ccs
App "concrete" ccs
]) = GFCC {
absname = a,
cncnames = [c | App c [] <- cs],
gflags = fromAscList [(f,v) | App f [AStr v] <- gfs],
absname = mkCId a,
cncnames = [mkCId c | App c [] <- cs],
gflags = fromAscList [(mkCId f,v) | App f [AStr v] <- gfs],
abstract =
let
aflags = fromAscList [(f,v) | App f [AStr v] <- gfs]
lfuns = [(f,(toType typ,toExp def)) | App f [typ, def] <- fs]
aflags = fromAscList [(mkCId f,v) | App f [AStr v] <- gfs]
lfuns = [(mkCId f,(toType typ,toExp def)) | App f [typ, def] <- fs]
funs = fromAscList lfuns
lcats = [(c, Prelude.map toHypo hyps) | App c hyps <- cts]
lcats = [(mkCId c, Prelude.map toHypo hyps) | App c hyps <- cts]
cats = fromAscList lcats
catfuns = fromAscList
[(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
in Abstr aflags funs cats catfuns,
concretes = fromAscList [(lang, toConcr ts) | App lang ts <- ccs]
concretes = fromAscList [(mkCId lang, toConcr ts) | App lang ts <- ccs]
}
where
@@ -57,71 +59,71 @@ toConcr = foldl add (Concr {
})
where
add :: Concr -> RExp -> Concr
add cnc (App (CId "flags") ts) = cnc { cflags = fromAscList [(f,v) | App f [AStr v] <- ts] }
add cnc (App (CId "lin") ts) = cnc { lins = mkTermMap ts }
add cnc (App (CId "oper") ts) = cnc { opers = mkTermMap ts }
add cnc (App (CId "lincat") ts) = cnc { lincats = mkTermMap ts }
add cnc (App (CId "lindef") ts) = cnc { lindefs = mkTermMap ts }
add cnc (App (CId "printname") ts) = cnc { printnames = mkTermMap ts }
add cnc (App (CId "param") ts) = cnc { paramlincats = mkTermMap ts }
add cnc (App (CId "parser") ts) = cnc { parser = Just (toPInfo ts) }
add cnc (App "flags" ts) = cnc { cflags = fromAscList [(mkCId f,v) | App f [AStr v] <- ts] }
add cnc (App "lin" ts) = cnc { lins = mkTermMap ts }
add cnc (App "oper" ts) = cnc { opers = mkTermMap ts }
add cnc (App "lincat" ts) = cnc { lincats = mkTermMap ts }
add cnc (App "lindef" ts) = cnc { lindefs = mkTermMap ts }
add cnc (App "printname" ts) = cnc { printnames = mkTermMap ts }
add cnc (App "param" ts) = cnc { paramlincats = mkTermMap ts }
add cnc (App "parser" ts) = cnc { parser = Just (toPInfo ts) }
toPInfo :: [RExp] -> FCFPInfo
toPInfo [App (CId "rules") rs, App (CId "startupcats") cs] = buildFCFPInfo (rules, cats)
toPInfo [App "rules" rs, App "startupcats" cs] = buildFCFPInfo (rules, cats)
where
rules = lmap toFRule rs
cats = fromList [(c, lmap expToInt fs) | App c fs <- cs]
cats = fromList [(mkCId c, lmap expToInt fs) | App c fs <- cs]
toFRule :: RExp -> FRule
toFRule (App (CId "rule")
toFRule (App "rule"
[n,
App (CId "cats") (rt:at),
App (CId "R") ls]) = FRule name args res lins
App "cats" (rt:at),
App "R" ls]) = FRule name args res lins
where
name = toFName n
args = lmap expToInt at
res = expToInt rt
lins = mkArray [mkArray [toSymbol s | s <- l] | App (CId "S") l <- ls]
lins = mkArray [mkArray [toSymbol s | s <- l] | App "S" l <- ls]
toFName :: RExp -> FName
toFName (App (CId "_A") [x]) = Name (CId "_") [Unify [expToInt x]]
toFName (App f ts) = Name f (lmap toProfile ts)
toFName (App "_A" [x]) = Name wildCId [Unify [expToInt x]]
toFName (App f ts) = Name (mkCId f) (lmap toProfile ts)
where
toProfile :: RExp -> Profile (SyntaxForest CId)
toProfile AMet = Unify []
toProfile (App (CId "_A") [t]) = Unify [expToInt t]
toProfile (App (CId "_U") ts) = Unify [expToInt t | App (CId "_A") [t] <- ts]
toProfile (App "_A" [t]) = Unify [expToInt t]
toProfile (App "_U" ts) = Unify [expToInt t | App "_A" [t] <- ts]
toProfile t = Constant (toSyntaxForest t)
toSyntaxForest :: RExp -> SyntaxForest CId
toSyntaxForest AMet = FMeta
toSyntaxForest (App n ts) = FNode n [lmap toSyntaxForest ts]
toSyntaxForest (App n ts) = FNode (mkCId n) [lmap toSyntaxForest ts]
toSyntaxForest (AStr s) = FString s
toSyntaxForest (AInt i) = FInt i
toSyntaxForest (AFlt f) = FFloat f
toSymbol :: RExp -> FSymbol
toSymbol (App (CId "P") [c,n,l]) = FSymCat (expToInt c) (expToInt l) (expToInt n)
toSymbol (App "P" [c,n,l]) = FSymCat (expToInt c) (expToInt l) (expToInt n)
toSymbol (AStr t) = FSymTok t
toType :: RExp -> Type
toType e = case e of
App cat [App (CId "H") hypos, App (CId "X") exps] ->
DTyp (lmap toHypo hypos) cat (lmap toExp exps)
App cat [App "H" hypos, App "X" exps] ->
DTyp (lmap toHypo hypos) (mkCId cat) (lmap toExp exps)
_ -> error $ "type " ++ show e
toHypo :: RExp -> Hypo
toHypo e = case e of
App x [typ] -> Hyp x (toType typ)
App x [typ] -> Hyp (mkCId x) (toType typ)
_ -> error $ "hypo " ++ show e
toExp :: RExp -> Exp
toExp e = case e of
App (CId "App") [App fun [], App (CId "B") xs, App (CId "X") exps] ->
DTr [x | App x [] <- xs] (AC fun) (lmap toExp exps)
App (CId "Eq") eqs ->
EEq [Equ (lmap toExp ps) (toExp v) | App (CId "E") (v:ps) <- eqs]
App (CId "Var") [App i []] -> DTr [] (AV i) []
App "App" [App fun [], App "B" xs, App "X" exps] ->
DTr [mkCId x | App x [] <- xs] (AC (mkCId fun)) (lmap toExp exps)
App "Eq" eqs ->
EEq [Equ (lmap toExp ps) (toExp v) | App "E" (v:ps) <- eqs]
App "Var" [App i []] -> DTr [] (AV (mkCId i)) []
AMet -> DTr [] (AM 0) []
AInt i -> DTr [] (AI i) []
AFlt i -> DTr [] (AF i) []
@@ -130,14 +132,14 @@ toExp e = case e of
toTerm :: RExp -> Term
toTerm e = case e of
App (CId "R") es -> R (lmap toTerm es)
App (CId "S") es -> S (lmap toTerm es)
App (CId "FV") es -> FV (lmap toTerm es)
App (CId "P") [e,v] -> P (toTerm e) (toTerm v)
App (CId "RP") [e,v] -> RP (toTerm e) (toTerm v) ----
App (CId "W") [AStr s,v] -> W s (toTerm v)
App (CId "A") [AInt i] -> V (fromInteger i)
App f [] -> F f
App "R" es -> R (lmap toTerm es)
App "S" es -> S (lmap toTerm es)
App "FV" es -> FV (lmap toTerm es)
App "P" [e,v] -> P (toTerm e) (toTerm v)
App "RP" [e,v] -> RP (toTerm e) (toTerm v) ----
App "W" [AStr s,v] -> W s (toTerm v)
App "A" [AInt i] -> V (fromInteger i)
App f [] -> F (mkCId f)
AInt i -> C (fromInteger i)
AMet -> TM "?"
AStr s -> K (KS s) ----
@@ -149,129 +151,124 @@ toTerm e = case e of
fromGFCC :: GFCC -> Grammar
fromGFCC gfcc0 = Grm [
app "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion
: App (absname gfcc) [] : lmap (flip App []) (cncnames gfcc)),
app "flags" [App f [AStr v] | (f,v) <- toList (gflags gfcc `union` aflags agfcc)],
app "abstract" [
app "fun" [App f [fromType t,fromExp d] | (f,(t,d)) <- toList (funs agfcc)],
app "cat" [App f (lmap fromHypo hs) | (f,hs) <- toList (cats agfcc)]
App "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion
: App (prCId (absname gfcc)) [] : lmap (flip App [] . prCId) (cncnames gfcc)),
App "flags" [App (prCId f) [AStr v] | (f,v) <- toList (gflags gfcc `union` aflags agfcc)],
App "abstract" [
App "fun" [App (prCId f) [fromType t,fromExp d] | (f,(t,d)) <- toList (funs agfcc)],
App "cat" [App (prCId f) (lmap fromHypo hs) | (f,hs) <- toList (cats agfcc)]
],
app "concrete" [App lang (fromConcrete c) | (lang,c) <- toList (concretes gfcc)]
App "concrete" [App (prCId lang) (fromConcrete c) | (lang,c) <- toList (concretes gfcc)]
]
where
gfcc = utf8GFCC gfcc0
app s = App (CId s)
agfcc = abstract gfcc
fromConcrete cnc = [
app "flags" [App f [AStr v] | (f,v) <- toList (cflags cnc)],
app "lin" [App f [fromTerm v] | (f,v) <- toList (lins cnc)],
app "oper" [App f [fromTerm v] | (f,v) <- toList (opers cnc)],
app "lincat" [App f [fromTerm v] | (f,v) <- toList (lincats cnc)],
app "lindef" [App f [fromTerm v] | (f,v) <- toList (lindefs cnc)],
app "printname" [App f [fromTerm v] | (f,v) <- toList (printnames cnc)],
app "param" [App f [fromTerm v] | (f,v) <- toList (paramlincats cnc)]
App "flags" [App (prCId f) [AStr v] | (f,v) <- toList (cflags cnc)],
App "lin" [App (prCId f) [fromTerm v] | (f,v) <- toList (lins cnc)],
App "oper" [App (prCId f) [fromTerm v] | (f,v) <- toList (opers cnc)],
App "lincat" [App (prCId f) [fromTerm v] | (f,v) <- toList (lincats cnc)],
App "lindef" [App (prCId f) [fromTerm v] | (f,v) <- toList (lindefs cnc)],
App "printname" [App (prCId f) [fromTerm v] | (f,v) <- toList (printnames cnc)],
App "param" [App (prCId f) [fromTerm v] | (f,v) <- toList (paramlincats cnc)]
] ++ maybe [] (\p -> [fromPInfo p]) (parser cnc)
fromType :: Type -> RExp
fromType e = case e of
DTyp hypos cat exps ->
App cat [
App (CId "H") (lmap fromHypo hypos),
App (CId "X") (lmap fromExp exps)]
App (prCId cat) [
App "H" (lmap fromHypo hypos),
App "X" (lmap fromExp exps)]
fromHypo :: Hypo -> RExp
fromHypo e = case e of
Hyp x typ -> App x [fromType typ]
Hyp x typ -> App (prCId x) [fromType typ]
fromExp :: Exp -> RExp
fromExp e = case e of
DTr xs (AC fun) exps ->
App (CId "App") [App fun [], App (CId "B") (lmap (flip App []) xs), App (CId "X") (lmap fromExp exps)]
DTr [] (AV x) [] -> App (CId "Var") [App x []]
App "App" [App (prCId fun) [], App "B" (lmap (flip App [] . prCId) xs), App "X" (lmap fromExp exps)]
DTr [] (AV x) [] -> App "Var" [App (prCId x) []]
DTr [] (AS s) [] -> AStr s
DTr [] (AF d) [] -> AFlt d
DTr [] (AI i) [] -> AInt (toInteger i)
DTr [] (AM _) [] -> AMet ----
EEq eqs ->
App (CId "Eq") [App (CId "E") (lmap fromExp (v:ps)) | Equ ps v <- eqs]
App "Eq" [App "E" (lmap fromExp (v:ps)) | Equ ps v <- eqs]
_ -> error $ "exp " ++ show e
fromTerm :: Term -> RExp
fromTerm e = case e of
R es -> app "R" (lmap fromTerm es)
S es -> app "S" (lmap fromTerm es)
FV es -> app "FV" (lmap fromTerm es)
P e v -> app "P" [fromTerm e, fromTerm v]
RP e v -> app "RP" [fromTerm e, fromTerm v] ----
W s v -> app "W" [AStr s, fromTerm v]
R es -> App "R" (lmap fromTerm es)
S es -> App "S" (lmap fromTerm es)
FV es -> App "FV" (lmap fromTerm es)
P e v -> App "P" [fromTerm e, fromTerm v]
RP e v -> App "RP" [fromTerm e, fromTerm v] ----
W s v -> App "W" [AStr s, fromTerm v]
C i -> AInt (toInteger i)
TM _ -> AMet
F f -> App f []
V i -> App (CId "A") [AInt (toInteger i)]
F f -> App (prCId f) []
V i -> App "A" [AInt (toInteger i)]
K (KS s) -> AStr s ----
K (KP d vs) -> app "FV" (str d : [str v | Var v _ <- vs]) ----
K (KP d vs) -> App "FV" (str d : [str v | Var v _ <- vs]) ----
where
app = App . CId
str v = app "S" (lmap AStr v)
str v = App "S" (lmap AStr v)
-- ** Parsing info
fromPInfo :: FCFPInfo -> RExp
fromPInfo p = app "parser" [
app "rules" [fromFRule rule | rule <- Array.elems (allRules p)],
app "startupcats" [App f (lmap intToExp cs) | (f,cs) <- toList (startupCats p)]
fromPInfo p = App "parser" [
App "rules" [fromFRule rule | rule <- Array.elems (allRules p)],
App "startupcats" [App (prCId f) (lmap intToExp cs) | (f,cs) <- toList (startupCats p)]
]
fromFRule :: FRule -> RExp
fromFRule (FRule n args res lins) =
app "rule" [fromFName n,
app "cats" (intToExp res:lmap intToExp args),
app "R" [app "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins]
App "rule" [fromFName n,
App "cats" (intToExp res:lmap intToExp args),
App "R" [App "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins]
]
fromFName :: FName -> RExp
fromFName n = case n of
Name (CId "_") [p] -> fromProfile p
Name f ps -> App f (lmap fromProfile ps)
Name f ps | f == wildCId -> fromProfile (head ps)
| otherwise -> App (prCId f) (lmap fromProfile ps)
where
fromProfile :: Profile (SyntaxForest CId) -> RExp
fromProfile (Unify []) = AMet
fromProfile (Unify [x]) = daughter x
fromProfile (Unify args) = app "_U" (lmap daughter args)
fromProfile (Unify args) = App "_U" (lmap daughter args)
fromProfile (Constant forest) = fromSyntaxForest forest
daughter n = app "_A" [intToExp n]
daughter n = App "_A" [intToExp n]
fromSyntaxForest :: SyntaxForest CId -> RExp
fromSyntaxForest FMeta = AMet
-- FIXME: is there always just one element here?
fromSyntaxForest (FNode n [args]) = App n (lmap fromSyntaxForest args)
fromSyntaxForest (FNode n [args]) = App (prCId n) (lmap fromSyntaxForest args)
fromSyntaxForest (FString s) = AStr s
fromSyntaxForest (FInt i) = AInt i
fromSyntaxForest (FFloat f) = AFlt f
fromSymbol :: FSymbol -> RExp
fromSymbol (FSymCat c l n) = app "P" [intToExp c, intToExp n, intToExp l]
fromSymbol (FSymCat c l n) = App "P" [intToExp c, intToExp n, intToExp l]
fromSymbol (FSymTok t) = AStr t
-- ** Utilities
mkTermMap :: [RExp] -> Map CId Term
mkTermMap ts = fromAscList [(f,toTerm v) | App f [v] <- ts]
app :: String -> [RExp] -> RExp
app = App . CId
mkTermMap ts = fromAscList [(mkCId f,toTerm v) | App f [v] <- ts]
mkArray :: [a] -> Array.Array Int a
mkArray xs = Array.listArray (0, length xs - 1) xs
expToInt :: Integral a => RExp -> a
expToInt (App (CId "neg") [AInt i]) = fromIntegral (negate i)
expToInt (App "neg" [AInt i]) = fromIntegral (negate i)
expToInt (AInt i) = fromIntegral i
expToStr :: RExp -> String
expToStr (AStr s) = s
intToExp :: Integral a => a -> RExp
intToExp x | x < 0 = App (CId "neg") [AInt (fromIntegral (negate x))]
intToExp x | x < 0 = App "neg" [AInt (fromIntegral (negate x))]
| otherwise = AInt (fromIntegral x)

4
src-3.0/GF/GFCC/Raw/ParGFCCRaw.hs
View File

@@ -1,9 +1,11 @@
module GF.GFCC.Raw.ParGFCCRaw (parseGrammar) where
import GF.GFCC.CId
import GF.GFCC.Raw.AbsGFCCRaw
import Control.Monad
import Data.Char
import qualified Data.ByteString.Char8 as BS
parseGrammar :: String -> IO Grammar
parseGrammar s = case runP pGrammar s of
@@ -27,7 +29,7 @@ pTerm n = skipSpaces >> (pParen <++ pApp <++ pNum <++ pStr <++ pMeta)
<++
return (AInt (read x)))
pMeta = char '?' >> return AMet
pIdent = liftM CId $ liftM2 (:) (satisfy isIdentFirst) (munch isIdentRest)
pIdent = liftM2 (:) (satisfy isIdentFirst) (munch isIdentRest)
isIdentFirst c = c == '_' || isAlpha c
isIdentRest c = c == '_' || c == '\'' || isAlphaNum c

9
src-3.0/GF/GFCC/Raw/PrintGFCCRaw.hs
View File

@@ -1,9 +1,11 @@
module GF.GFCC.Raw.PrintGFCCRaw (printTree) where
import GF.GFCC.CId
import GF.GFCC.Raw.AbsGFCCRaw
import Data.List (intersperse)
import Numeric (showFFloat)
import qualified Data.ByteString.Char8 as BS
printTree :: Grammar -> String
printTree g = prGrammar g ""
@@ -12,8 +14,8 @@ prGrammar :: Grammar -> ShowS
prGrammar (Grm xs) = prRExpList xs
prRExp :: Int -> RExp -> ShowS
prRExp _ (App x []) = prCId x
prRExp n (App x xs) = p (prCId x . showChar ' ' . prRExpList xs)
prRExp _ (App x []) = showString x
prRExp n (App x xs) = p (showString x . showChar ' ' . prRExpList xs)
where p s = if n == 0 then s else showChar '(' . s . showChar ')'
prRExp _ (AInt x) = shows x
prRExp _ (AStr x) = showChar '"' . concatS (map mkEsc x) . showChar '"'
@@ -29,8 +31,5 @@ mkEsc s = case s of
prRExpList :: [RExp] -> ShowS
prRExpList = concatS . intersperse (showChar ' ') . map (prRExp 1)
prCId :: CId -> ShowS
prCId (CId x) = showString x
concatS :: [ShowS] -> ShowS
concatS = foldr (.) id

130
src-3.0/GF/Grammar/AppPredefined.hs
View File

@@ -15,12 +15,13 @@
module GF.Grammar.AppPredefined (isInPredefined, typPredefined, appPredefined
) where
import GF.Data.Operations
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Data.Operations
import GF.Grammar.Predef
import GF.Grammar.Grammar
import GF.Grammar.Macros
import GF.Grammar.PrGrammar (prt,prt_,prtBad)
---- import PGrammar (pTrm)
import qualified Data.ByteString.Char8 as BS
-- predefined function type signatures and definitions. AR 12/3/2003.
@@ -28,75 +29,77 @@ isInPredefined :: Ident -> Bool
isInPredefined = err (const True) (const False) . typPredefined
typPredefined :: Ident -> Err Type
typPredefined c@(IC f) = case f of
"Int" -> return typePType
"Float" -> return typePType
"Error" -> return typeType
"Ints" -> return $ mkFunType [cnPredef "Int"] typePType
"PBool" -> return typePType
"error" -> return $ mkFunType [typeStr] (cnPredef "Error") -- non-can. of empty set
"PFalse" -> return $ cnPredef "PBool"
"PTrue" -> return $ cnPredef "PBool"
"dp" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
"drop" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
"eqInt" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
"lessInt"-> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
"eqStr" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
"length" -> return $ mkFunType [typeTok] (cnPredef "Int")
"occur" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
"occurs" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
"plus" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "Int")
typPredefined f
| f == cInt = return typePType
| f == cFloat = return typePType
| f == cErrorType = return typeType
| f == cInts = return $ mkFunType [typeInt] typePType
| f == cPBool = return typePType
| f == cError = return $ mkFunType [typeStr] typeError -- non-can. of empty set
| f == cPFalse = return $ typePBool
| f == cPTrue = return $ typePBool
| f == cDp = return $ mkFunType [typeInt,typeTok] typeTok
| f == cDrop = return $ mkFunType [typeInt,typeTok] typeTok
| f == cEqInt = return $ mkFunType [typeInt,typeInt] typePBool
| f == cLessInt = return $ mkFunType [typeInt,typeInt] typePBool
| f == cEqStr = return $ mkFunType [typeTok,typeTok] typePBool
| f == cLength = return $ mkFunType [typeTok] typeInt
| f == cOccur = return $ mkFunType [typeTok,typeTok] typePBool
| f == cOccurs = return $ mkFunType [typeTok,typeTok] typePBool
| f == cPlus = return $ mkFunType [typeInt,typeInt] (typeInt)
---- "read" -> (P : Type) -> Tok -> P
"show" -> return $ mkProd -- (P : PType) -> P -> Tok
([(zIdent "P",typePType),(wildIdent,Vr (zIdent "P"))],typeStr,[])
"toStr" -> return $ mkProd -- (L : Type) -> L -> Str
([(zIdent "L",typeType),(wildIdent,Vr (zIdent "L"))],typeStr,[])
"mapStr" ->
let ty = zIdent "L" in
return $ mkProd -- (L : Type) -> (Str -> Str) -> L -> L
([(ty,typeType),(wildIdent,mkFunType [typeStr] typeStr),(wildIdent,Vr ty)],Vr ty,[])
"take" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
"tk" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
_ -> prtBad "unknown in Predef:" c
typPredefined c = prtBad "unknown in Predef:" c
| f == cShow = return $ mkProd -- (P : PType) -> P -> Tok
([(varP,typePType),(identW,Vr varP)],typeStr,[])
| f == cToStr = return $ mkProd -- (L : Type) -> L -> Str
([(varL,typeType),(identW,Vr varL)],typeStr,[])
| f == cMapStr = return $ mkProd -- (L : Type) -> (Str -> Str) -> L -> L
([(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
varL :: Ident
varL = identC (BS.pack "L")
varP :: Ident
varP = identC (BS.pack "P")
appPredefined :: Term -> Err (Term,Bool)
appPredefined t = case t of
App f x0 -> do
(x,_) <- appPredefined x0
case f of
-- one-place functions
Q (IC "Predef") (IC f) -> case (f, x) of
("length", K s) -> retb $ EInt $ toInteger $ length s
_ -> retb t ---- prtBad "cannot compute predefined" t
Q mod f | mod == cPredef ->
case x of
(K s) | f == cLength -> retb $ EInt $ toInteger $ length s
_ -> retb t
-- two-place functions
App (Q (IC "Predef") (IC f)) z0 -> do
App (Q mod f) z0 | mod == cPredef -> do
(z,_) <- appPredefined z0
case (f, norm z, norm x) of
("drop", EInt i, K s) -> retb $ K (drop (fi i) s)
("take", EInt i, K s) -> retb $ K (take (fi i) s)
("tk", EInt i, K s) -> retb $ K (take (max 0 (length s - fi i)) s)
("dp", EInt i, K s) -> retb $ K (drop (max 0 (length s - fi i)) s)
("eqStr",K s, K t) -> retb $ if s == t then predefTrue else predefFalse
("occur",K s, K t) -> retb $ if substring s t then predefTrue else predefFalse
("occurs",K s, K t) -> retb $ if any (flip elem t) s then predefTrue else predefFalse
("eqInt",EInt i, EInt j) -> retb $ if i==j then predefTrue else predefFalse
("lessInt",EInt i, EInt j) -> retb $ if i<j then predefTrue else predefFalse
("plus", EInt i, EInt j) -> retb $ EInt $ i+j
("show", _, t) -> retb $ foldr C Empty $ map K $ words $ prt t
("read", _, K s) -> retb $ str2tag s --- because of K, only works for atomic tags
("toStr", _, t) -> trm2str t >>= retb
case (norm z, norm x) of
(EInt i, K s) | f == cDrop -> retb $ K (drop (fi i) s)
(EInt i, K s) | f == cTake -> retb $ K (take (fi i) s)
(EInt i, K s) | f == cTk -> retb $ K (take (max 0 (length s - fi i)) s)
(EInt i, K s) | f == cDp -> retb $ K (drop (max 0 (length s - fi i)) s)
(K s, K t) | f == cEqStr -> retb $ if s == t then predefTrue else predefFalse
(K s, K t) | f == cOccur -> retb $ if substring s t then predefTrue else predefFalse
(K s, K t) | f == cOccurs -> retb $ if any (flip elem t) s then predefTrue else predefFalse
(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
(_, 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
-- three-place functions
App (App (Q (IC "Predef") (IC f)) z0) y0 -> do
App (App (Q mod f) z0) y0 | mod == cPredef -> do
(y,_) <- appPredefined y0
(z,_) <- appPredefined z0
case (f, z, y, x) of
("mapStr",ty,op,t) -> retf $ mapStr ty op t
case (z, y, x) of
(ty,op,t) | f == cMapStr -> retf $ mapStr ty op t
_ -> retb t ---- prtBad "cannot compute predefined" t
_ -> retb t ---- prtBad "cannot compute predefined" t
@@ -112,19 +115,8 @@ appPredefined t = case t of
-- read makes variables into constants
str2tag :: String -> Term
str2tag s = case s of
---- '\'' : cs -> mkCn $ pTrm $ init cs
_ -> Cn $ IC s ---
where
mkCn t = case t of
Vr i -> Cn i
App c a -> App (mkCn c) (mkCn a)
_ -> t
predefTrue = Q (IC "Predef") (IC "PTrue")
predefFalse = Q (IC "Predef") (IC "PFalse")
predefTrue = Q cPredef cPTrue
predefFalse = Q cPredef cPFalse
substring :: String -> String -> Bool
substring s t = case (s,t) of

25
src-3.0/GF/Grammar/Grammar.hs
View File

@@ -48,7 +48,8 @@ module GF.Grammar.Grammar (SourceGrammar,
Con,
Trm,
wildPatt,
varLabel
varLabel, tupleLabel, linLabel, theLinLabel,
ident2label, label2ident
) where
import GF.Data.Str
@@ -58,6 +59,8 @@ import GF.Infra.Modules
import GF.Data.Operations
import qualified Data.ByteString.Char8 as BS
-- | grammar as presented to the compiler
type SourceGrammar = MGrammar Ident Option Info
@@ -119,7 +122,7 @@ data Term =
| Cn Ident -- ^ constant
| Con Ident -- ^ constructor
| EData -- ^ to mark in definition that a fun is a constructor
| Sort String -- ^ basic type
| Sort Ident -- ^ basic type
| EInt Integer -- ^ integer literal
| EFloat Double -- ^ floating point literal
| K String -- ^ string literal or token: @\"foo\"@
@@ -210,7 +213,7 @@ data TInfo =
-- | record label
data Label =
LIdent String
LIdent BS.ByteString
| LVar Int
deriving (Read, Show, Eq, Ord)
@@ -238,7 +241,21 @@ type Con = Ident ---
varLabel :: Int -> Label
varLabel = LVar
tupleLabel, linLabel :: Int -> Label
tupleLabel i = LIdent $! BS.pack ('p':show i)
linLabel i = LIdent $! BS.pack ('s':show i)
theLinLabel :: Label
theLinLabel = LIdent (BS.singleton 's')
ident2label :: Ident -> Label
ident2label c = LIdent (ident2bs c)
label2ident :: Label -> Ident
label2ident (LIdent s) = identC s
label2ident (LVar i) = identC (BS.pack ('$':show i))
wildPatt :: Patt
wildPatt = PV wildIdent
wildPatt = PV identW
type Trm = Term

13
src-3.0/GF/Grammar/Lockfield.hs
View File

@@ -16,8 +16,10 @@
module GF.Grammar.Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where
import GF.Grammar.Grammar
import qualified Data.ByteString.Char8 as BS
import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.Macros
import GF.Grammar.PrGrammar
@@ -38,9 +40,12 @@ unlockRecord c ft = do
return $ mkAbs xs t'
lockLabel :: Ident -> Label
lockLabel c = LIdent $ "lock_" ++ prt c ----
lockLabel c = LIdent $! BS.append lockPrefix (ident2bs c)
isLockLabel :: Label -> Bool
isLockLabel l = case l of
LIdent c -> take 5 c == "lock_"
_ -> False
LIdent c -> BS.isPrefixOf lockPrefix c
_ -> False
lockPrefix = BS.pack "lock_"

2
src-3.0/GF/Grammar/LookAbs.hs
View File

@@ -115,7 +115,7 @@ lookupRef gr binds at = case at of
refsForType :: (Val -> Type -> Bool) -> GFCGrammar -> Binds -> Val -> [(Term,(Val,Bool))]
refsForType compat gr binds val =
-- bound variables --- never recursive?
[(vr i, (t,False)) | (i,t) <- binds, Ok ty <- [val2exp t], compat val ty] ++
[(Vr i, (t,False)) | (i,t) <- binds, Ok ty <- [val2exp t], compat val ty] ++
-- integer and string literals
[(EInt i, (val,False)) | val == valAbsInt, i <- [0,1,2,5,11,1978]] ++
[(EFloat i, (val,False)) | val == valAbsFloat, i <- [3.1415926]] ++

21
src-3.0/GF/Grammar/Lookup.hs
View File

@@ -1,3 +1,4 @@
{-# LANGUAGE PatternGuards #-}
----------------------------------------------------------------------
-- |
-- Module : Lookup
@@ -28,13 +29,13 @@ module GF.Grammar.Lookup (
allParamValues,
lookupAbsDef,
lookupLincat,
opersForType,
linTypeInt
opersForType
) where
import GF.Data.Operations
import GF.Grammar.Abstract
import GF.Infra.Modules
import GF.Grammar.Predef
import GF.Grammar.Lockfield
import Data.List (nub,sortBy)
@@ -192,8 +193,7 @@ allOrigInfos gr m = errVal [] $ do
allParamValues :: SourceGrammar -> Type -> Err [Term]
allParamValues cnc ptyp = case ptyp of
App (Q (IC "Predef") (IC "Ints")) (EInt n) ->
return [EInt i | i <- [0..n]]
_ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
QC p c -> lookupParamValues cnc p c
Q p c -> lookupParamValues cnc p c ----
RecType r -> do
@@ -230,17 +230,8 @@ lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do
_ -> return Nothing
_ -> Bad $ prt m +++ "is not an abstract module"
linTypeInt :: Type
linTypeInt = defLinType
--- let ints k = App (Q (IC "Predef") (IC "Ints")) (EInt k) in
--- RecType [
--- (LIdent "last",ints 9),(LIdent "s", typeStr), (LIdent "size",ints 1)]
lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type
lookupLincat gr m c | elem c [zIdent "Int"] = return linTypeInt
lookupLincat gr m c | elem c [zIdent "String", zIdent "Float"] =
return defLinType --- ad hoc; not needed?
lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
lookupLincat gr m c = do
mi <- lookupModule gr m
case mi of
@@ -265,7 +256,7 @@ opersForType gr orig val =
Ok valt <- [valTypeCnc ty],
elem valt [val,orig]
] ++
let cat = err zIdent snd (valCat orig) in --- ignore module
let cat = err error snd (valCat orig) in --- ignore module
[(f,ty) |
Ok a <- [abstractOfConcrete gr i >>= lookupModMod gr],
(f, AbsFun (Yes ty0) _) <- tree2list $ jments a,

20
src-3.0/GF/Grammar/MMacros.hs
View File

@@ -26,6 +26,7 @@ import GF.Grammar.Values
import GF.Grammar.Macros
import Control.Monad
import qualified Data.ByteString.Char8 as BS
nodeTree :: Tree -> TrNode
argsTree :: Tree -> [Tree]
@@ -120,9 +121,6 @@ funAtom a = case a of
AtC f -> return f
_ -> prtBad "not function head" a
uBoundVar :: Ident
uBoundVar = zIdent "#h" -- used for suppressed bindings
atomIsMeta :: Atom -> Bool
atomIsMeta atom = case atom of
AtM _ -> True
@@ -186,7 +184,7 @@ val2expP safe v = case v of
VCn c -> return $ qq c
VGen i x -> if safe
then prtBad "unsafe val2exp" v
else return $ vr $ x --- in editing, no alpha conversions presentv
else return $ Vr $ x --- in editing, no alpha conversions presentv
where
substVal g e = mapPairsM (val2expP safe) g >>= return . (\s -> substTerm [] s e)
@@ -278,7 +276,7 @@ mkJustProd :: Context -> Term -> Term
mkJustProd cont typ = mkProd (cont,typ,[])
int2var :: Int -> Ident
int2var = zIdent . ('$':) . show
int2var = identC . BS.pack . ('$':) . show
meta0 :: Meta
meta0 = int2meta 0
@@ -301,12 +299,12 @@ qualifTerm m = qualif [] where
Cn c -> Q m c
Con c -> QC m c
_ -> composSafeOp (qualif xs) t
chV x = string2var $ prIdent x
chV x = string2var $ ident2bs x
string2var :: String -> Ident
string2var s = case s of
c:'_':i -> identV (readIntArg i,[c]) ---
_ -> zIdent s
string2var :: BS.ByteString -> Ident
string2var s = case BS.unpack s of
c:'_':i -> identV (BS.singleton c) (readIntArg i) ---
_ -> identC s
-- | reindex variables so that they tell nesting depth level
reindexTerm :: Term -> Term
@@ -317,7 +315,7 @@ reindexTerm = qualif (0,[]) where
Vr x -> Vr $ look x g
_ -> composSafeOp (qualif dg) t
look x = maybe x id . lookup x --- if x is not in scope it is unchanged
ind x d = identC $ prIdent x ++ "_" ++ show d
ind x d = identC $ ident2bs x `BS.append` BS.singleton '_' `BS.append` BS.pack (show d)
-- this method works for context-free abstract syntax

183
src-3.0/GF/Grammar/Macros.hs
View File

@@ -20,8 +20,10 @@ module GF.Grammar.Macros where
import GF.Data.Operations
import GF.Data.Str
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.Values
import GF.Grammar.Predef
import GF.Grammar.PrGrammar
import Control.Monad (liftM, liftM2)
@@ -55,12 +57,6 @@ qq (m,c) = Q m c
typeForm :: Type -> Err (Context, Cat, [Term])
typeForm = qTypeForm ---- no need to distinguish any more
cPredef :: Ident
cPredef = identC "Predef"
cnPredef :: String -> Term
cnPredef f = Q cPredef (identC f)
typeFormCnc :: Type -> Err (Context, Type)
typeFormCnc t = case t of
Prod x a b -> do
@@ -91,18 +87,11 @@ typeRawSkeleton typ =
type MCat = (Ident,Ident)
sortMCat :: String -> MCat
sortMCat s = (zIdent "_", zIdent s)
--- hack for Editing.actCat in empty state
errorCat :: MCat
errorCat = (zIdent "?", zIdent "?")
getMCat :: Term -> Err MCat
getMCat t = case t of
Q m c -> return (m,c)
QC m c -> return (m,c)
Sort s -> return $ sortMCat s
Sort c -> return (identW, c)
App f _ -> getMCat f
_ -> prtBad "no qualified constant" t
@@ -213,12 +202,6 @@ mkAbs xx t = foldr Abs t xx
appCons :: Ident -> [Term] -> Term
appCons = mkApp . Cn
appc :: String -> [Term] -> Term
appc = appCons . zIdent
appqc :: String -> String -> [Term] -> Term
appqc q c = mkApp (Q (zIdent q) (zIdent c))
mkLet :: [LocalDef] -> Term -> Term
mkLet defs t = foldr Let t defs
@@ -232,11 +215,8 @@ isVariable _ = False
eqIdent :: Ident -> Ident -> Bool
eqIdent = (==)
zIdent :: String -> Ident
zIdent s = identC s
uType :: Type
uType = Cn (zIdent "UndefinedType")
uType = Cn cUndefinedType
assign :: Label -> Term -> Assign
assign l t = (l,(Nothing,t))
@@ -253,15 +233,6 @@ mkAssign lts = [assign l t | (l,t) <- lts]
zipAssign :: [Label] -> [Term] -> [Assign]
zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
ident2label :: Ident -> Label
ident2label c = LIdent (prIdent c)
label2ident :: Label -> Ident
label2ident = identC . prLabel
prLabel :: Label -> String
prLabel = prt
mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv))
where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v)
@@ -280,41 +251,40 @@ mkRecType = mkRecTypeN 0
record2subst :: Term -> Err Substitution
record2subst t = case t of
R fs -> return [(zIdent x, t) | (LIdent x,(_,t)) <- fs]
R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs]
_ -> prtBad "record expected, found" t
typeType, typePType, typeStr, typeTok, typeStrs :: Term
typeType = srt "Type"
typePType = srt "PType"
typeStr = srt "Str"
typeTok = srt "Tok"
typeStrs = srt "Strs"
typeType = Sort cType
typePType = Sort cPType
typeStr = Sort cStr
typeTok = Sort cTok
typeStrs = Sort cStrs
typeString, typeFloat, typeInt :: Term
typeInts :: Integer -> Term
typePBool :: Term
typeError :: Term
typeString = constPredefRes "String"
typeInt = constPredefRes "Int"
typeFloat = constPredefRes "Float"
typeInts i = App (constPredefRes "Ints") (EInt i)
typeString = cnPredef cString
typeInt = cnPredef cInt
typeFloat = cnPredef cFloat
typeInts i = App (cnPredef cInts) (EInt i)
typePBool = cnPredef cPBool
typeError = cnPredef cErrorType
isTypeInts :: Term -> Bool
isTypeInts ty = case ty of
App c _ -> c == constPredefRes "Ints"
_ -> False
constPredefRes :: String -> Term
constPredefRes s = Q (IC "Predef") (zIdent s)
isTypeInts :: Term -> Maybe Integer
isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
isTypeInts _ = Nothing
isPredefConstant :: Term -> Bool
isPredefConstant t = case t of
Q (IC "Predef") _ -> True
Q (IC "PredefAbs") _ -> True
_ -> False
Q mod _ | mod == cPredef || mod == cPredefAbs -> True
_ -> False
isPredefAbsType :: Ident -> Bool
isPredefAbsType c = elem c [zIdent "Int", zIdent "String"]
cnPredef :: Ident -> Term
cnPredef f = Q cPredef f
mkSelects :: Term -> [Term] -> Term
mkSelects t tt = foldl S t tt
@@ -327,18 +297,11 @@ mkCTable ids v = foldr ccase v ids where
ccase x t = T TRaw [(PV x,t)]
mkDecl :: Term -> Decl
mkDecl typ = (wildIdent, typ)
mkDecl typ = (identW, typ)
eqStrIdent :: Ident -> Ident -> Bool
eqStrIdent = (==)
tupleLabel, linLabel :: Int -> Label
tupleLabel i = LIdent $ "p" ++ show i
linLabel i = LIdent $ "s" ++ show i
theLinLabel :: Label
theLinLabel = LIdent "s"
tuple2record :: [Term] -> [Assign]
tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]
@@ -352,10 +315,10 @@ mkCases :: Ident -> Term -> Term
mkCases x t = T TRaw [(PV x, t)]
mkWildCases :: Term -> Term
mkWildCases = mkCases wildIdent
mkWildCases = mkCases identW
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
plusRecType :: Type -> Type -> Err Type
plusRecType t1 t2 = case (unComputed t1, unComputed t2) of
@@ -376,11 +339,7 @@ plusRecord t1 t2 =
-- | default linearization type
defLinType :: Type
defLinType = RecType [(LIdent "s", typeStr)]
-- | refreshing variables
varX :: Int -> Ident
varX i = identV (i,"x")
defLinType = RecType [(theLinLabel, typeStr)]
-- | refreshing variables
mkFreshVar :: [Ident] -> Ident
@@ -414,28 +373,12 @@ float2term = EFloat
ident2terminal :: Ident -> Term
ident2terminal = K . prIdent
-- | create a constant
string2CnTrm :: String -> Term
string2CnTrm = Cn . zIdent
symbolOfIdent :: Ident -> String
symbolOfIdent = prIdent
symid :: Ident -> String
symid = symbolOfIdent
vr :: Ident -> Term
cn :: Ident -> Term
srt :: String -> Term
meta :: MetaSymb -> Term
cnIC :: String -> Term
vr = Vr
cn = Cn
srt = Sort
meta = Meta
cnIC = cn . IC
justIdentOf :: Term -> Maybe Ident
justIdentOf (Vr x) = Just x
justIdentOf (Cn x) = Just x
@@ -490,9 +433,6 @@ linTypeStr = mkRecType linLabel [typeStr] -- default lintype {s :: Str}
linAsStr :: String -> Term
linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s}
linDefStr :: Term
linDefStr = Abs s (R [assign (linLabel 0) (Vr s)]) where s = zIdent "s"
term2patt :: Term -> Err Patt
term2patt trm = case termForm trm of
Ok ([], Vr x, []) -> return (PV x)
@@ -516,24 +456,24 @@ term2patt trm = case termForm trm of
Ok ([],K s, []) -> return $ PString s
--- encodings due to excessive use of term-patt convs. AR 7/1/2005
Ok ([], Cn (IC "@"), [Vr a,b]) -> do
Ok ([], Cn id, [Vr a,b]) | id == cAs -> do
b' <- term2patt b
return (PAs a b')
Ok ([], Cn (IC "-"), [a]) -> do
Ok ([], Cn id, [a]) | id == cNeg -> do
a' <- term2patt a
return (PNeg a')
Ok ([], Cn (IC "*"), [a]) -> do
Ok ([], Cn id, [a]) | id == cRep -> do
a' <- term2patt a
return (PRep a')
Ok ([], Cn (IC "?"), []) -> do
Ok ([], Cn id, []) | id == cRep -> do
return PChar
Ok ([], Cn (IC "[]"),[K s]) -> do
Ok ([], Cn id,[K s]) | id == cChars -> do
return $ PChars s
Ok ([], Cn (IC "+"), [a,b]) -> do
Ok ([], Cn id, [a,b]) | id == cSeq -> do
a' <- term2patt a
b' <- term2patt b
return (PSeq a' b')
Ok ([], Cn (IC "|"), [a,b]) -> do
Ok ([], Cn id, [a,b]) | id == cAlt -> do
a' <- term2patt a
b' <- term2patt b
return (PAlt a' b')
@@ -546,7 +486,7 @@ term2patt trm = case termForm trm 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
PVal t i -> Val t i
PMacro c -> Cn c
PM p c -> Q p c
@@ -560,13 +500,13 @@ patt2term pt = case pt of
PFloat i -> EFloat i
PString s -> K s
PAs x p -> appc "@" [Vr x, patt2term p] --- an encoding
PChar -> appc "?" [] --- an encoding
PChars s -> appc "[]" [K s] --- an encoding
PSeq a b -> appc "+" [(patt2term a), (patt2term b)] --- an encoding
PAlt a b -> appc "|" [(patt2term a), (patt2term b)] --- an encoding
PRep a -> appc "*" [(patt2term a)] --- an encoding
PNeg a -> appc "-" [(patt2term a)] --- an encoding
PAs x p -> appCons cAs [Vr x, patt2term p] --- an encoding
PChar -> appCons cChar [] --- an encoding
PChars s -> appCons cChars [K s] --- an encoding
PSeq a b -> appCons cSeq [(patt2term a), (patt2term b)] --- an encoding
PAlt a b -> appCons cAlt [(patt2term a), (patt2term b)] --- an encoding
PRep a -> appCons cRep [(patt2term a)] --- an encoding
PNeg a -> appCons cNeg [(patt2term a)] --- an encoding
redirectTerm :: Ident -> Term -> Term
@@ -575,45 +515,12 @@ redirectTerm n t = case t of
Q _ f -> Q n f
_ -> composSafeOp (redirectTerm n) t
-- | to gather s-fields; assumes term in normal form, preserves label
allLinFields :: Term -> Err [[(Label,Term)]]
allLinFields trm = case unComputed trm of
---- R rs -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good
R rs -> return [[(l,t) | (l,(_,t)) <- rs, isLinLabel l]] ---- bad
FV ts -> do
lts <- mapM allLinFields ts
return $ concat lts
_ -> prtBad "fields can only be sought in a record not in" trm
-- | deprecated
isLinLabel :: Label -> Bool
isLinLabel l = case l of
LIdent ('s':cs) | all isDigit cs -> True
_ -> False
-- | to gather ultimate cases in a table; preserves pattern list
allCaseValues :: Term -> [([Patt],Term)]
allCaseValues trm = case unComputed trm of
T _ cs -> [(p:ps, t) | (p,t0) <- cs, (ps,t) <- allCaseValues t0]
_ -> [([],trm)]
-- | to gather all linearizations; assumes normal form, preserves label and args
allLinValues :: Term -> Err [[(Label,[([Patt],Term)])]]
allLinValues trm = do
lts <- allLinFields trm
mapM (mapPairsM (return . allCaseValues)) lts
-- | to mark str parts of fields in a record f by a function f
markLinFields :: (Term -> Term) -> Term -> Term
markLinFields f t = case t of
R r -> R $ map mkField r
_ -> t
where
mkField (l,(_,t)) = if (isLinLabel l) then (assign l (mkTbl t)) else (assign l t)
mkTbl t = case t of
T i cs -> T i [(p, mkTbl v) | (p,v) <- cs]
_ -> f t
-- | to get a string from a term that represents a sequence of terminals
strsFromTerm :: Term -> Err [Str]
strsFromTerm t = case unComputed t of

24
src-3.0/GF/Grammar/Values.hs
View File

@@ -19,15 +19,15 @@ module GF.Grammar.Values (-- * values used in TC type checking
-- * for TC
valAbsInt, valAbsFloat, valAbsString, vType,
isPredefCat,
cType, cPredefAbs, cInt, cFloat, cString,
eType, tree2exp, loc2treeFocus
) where
import GF.Data.Operations
import GF.Data.Zipper
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.Predef
-- values used in TC type checking
@@ -67,26 +67,8 @@ valAbsString = VCn (cPredefAbs, cString)
vType :: Val
vType = VType
cType :: Ident
cType = identC "Type" --- #0
cPredefAbs :: Ident
cPredefAbs = identC "PredefAbs"
cInt :: Ident
cInt = identC "Int"
cFloat :: Ident
cFloat = identC "Float"
cString :: Ident
cString = identC "String"
isPredefCat :: Ident -> Bool
isPredefCat c = elem c [cInt,cString,cFloat]
eType :: Exp
eType = Sort "Type"
eType = Sort cType
tree2exp :: Tree -> Exp
tree2exp (Tr (N (bi,at,_,_,_),ts)) = foldr Abs (foldl App at' ts') bi' where

69
src-3.0/GF/Infra/Ident.hs
View File

@@ -13,45 +13,48 @@
-----------------------------------------------------------------------------
module GF.Infra.Ident (-- * Identifiers
Ident(..), prIdent,
Ident(..), ident2bs, prIdent,
identC, identV, identA, identAV, identW,
argIdent, strVar, wildIdent, isWildIdent,
newIdent, mkIdent, varIndex,
argIdent, varStr, varX, isWildIdent, varIndex,
-- * refreshing identifiers
IdState, initIdStateN, initIdState,
lookVar, refVar, refVarPlus
) where
import GF.Data.Operations
import qualified Data.ByteString.Char8 as BS
-- import Monad
-- | the constructors labelled /INTERNAL/ are
-- internal representation never returned by the parser
data Ident =
IC String -- ^ raw identifier after parsing, resolved in Rename
| IW -- ^ wildcard
IC !BS.ByteString -- ^ raw identifier after parsing, resolved in Rename
| IW -- ^ wildcard
--
-- below this constructor: internal representation never returned by the parser
| IV (Int,String) -- ^ /INTERNAL/ variable
| IA (String,Int) -- ^ /INTERNAL/ argument of cat at position
| IAV (String,Int,Int) -- ^ /INTERNAL/ argument of cat with bindings at position
| IV !BS.ByteString Int -- ^ /INTERNAL/ variable
| IA !BS.ByteString Int -- ^ /INTERNAL/ argument of cat at position
| IAV !BS.ByteString Int Int -- ^ /INTERNAL/ argument of cat with bindings at position
--
deriving (Eq, Ord, Show, Read)
prIdent :: Ident -> String
prIdent i = case i of
ident2bs :: Ident -> BS.ByteString
ident2bs i = case i of
IC s -> s
IV (n,s) -> s ++ "_" ++ show n
IA (s,j) -> s ++ "_" ++ show j
IAV (s,b,j) -> s ++ "_" ++ show b ++ "_" ++ show j
IW -> "_"
IV s n -> BS.append s (BS.pack ('_':show n))
IA s j -> BS.append s (BS.pack ('_':show j))
IAV s b j -> BS.append s (BS.pack ('_':show b ++ '_':show j))
IW -> BS.singleton '_'
identC :: String -> Ident
identV :: (Int, String) -> Ident
identA :: (String, Int) -> Ident
identAV:: (String, Int, Int) -> Ident
prIdent :: Ident -> String
prIdent i = BS.unpack $! ident2bs i
identC :: BS.ByteString -> Ident
identV :: BS.ByteString -> Int -> Ident
identA :: BS.ByteString -> Int -> Ident
identAV:: BS.ByteString -> Int -> Int -> Ident
identW :: Ident
(identC, identV, identA, identAV, identW) =
(IC, IV, IA, IAV, IW)
@@ -61,31 +64,25 @@ identW :: Ident
-- | to mark argument variables
argIdent :: Int -> Ident -> Int -> Ident
argIdent 0 (IC c) i = identA (c,i)
argIdent b (IC c) i = identAV (c,b,i)
argIdent 0 (IC c) i = identA c i
argIdent b (IC c) i = identAV c b i
-- | used in lin defaults
strVar :: Ident
strVar = identA ("str",0)
varStr :: Ident
varStr = identA (BS.pack "str") 0
-- | wild card
wildIdent :: Ident
wildIdent = identW
-- | refreshing variables
varX :: Int -> Ident
varX = identV (BS.singleton 'x')
isWildIdent :: Ident -> Bool
isWildIdent x = case x of
IW -> True
IC "_" -> True
IC s | s == BS.pack "_" -> True
_ -> False
newIdent :: Ident
newIdent = identC "#h"
mkIdent :: String -> Int -> Ident
mkIdent s i = identV (i,s)
varIndex :: Ident -> Int
varIndex (IV (n,_)) = n
varIndex (IV _ n) = n
varIndex _ = -1 --- other than IV should not count
-- refreshing identifiers
@@ -99,7 +96,7 @@ initIdState :: IdState
initIdState = initIdStateN 0
lookVar :: Ident -> STM IdState Ident
lookVar a@(IA _) = return a
lookVar a@(IA _ _) = return a
lookVar x = do
(sys,_) <- readSTM
stm (\s -> maybe (Bad ("cannot find" +++ show x +++ prParenth (show sys)))
@@ -110,8 +107,8 @@ refVar :: Ident -> STM IdState Ident
----refVar IW = return IW --- no update of wildcard
refVar x = do
(_,m) <- readSTM
let x' = IV (m, prIdent x)
updateSTM (\ (sys,mx) -> ((x, x'):sys, mx + 1))
let x' = IV (ident2bs x) m
updateSTM (\(sys,mx) -> ((x, x'):sys, mx + 1))
return x'
refVarPlus :: Ident -> STM IdState Ident

613
src-3.0/GF/Source/AbsGF.hs
View File

@@ -1,306 +1,307 @@
module GF.Source.AbsGF where
-- Haskell module generated by the BNF converter
newtype LString = LString String deriving (Eq,Ord,Show)
newtype PIdent = PIdent ((Int,Int),String) deriving (Eq,Ord,Show)
data Grammar =
Gr [ModDef]
deriving (Eq,Ord,Show)
data ModDef =
MMain PIdent PIdent [ConcSpec]
| MModule ComplMod ModType ModBody
deriving (Eq,Ord,Show)
data ConcSpec =
ConcSpec PIdent ConcExp
deriving (Eq,Ord,Show)
data ConcExp =
ConcExp PIdent [Transfer]
deriving (Eq,Ord,Show)
data Transfer =
TransferIn Open
| TransferOut Open
deriving (Eq,Ord,Show)
data ModType =
MTAbstract PIdent
| MTResource PIdent
| MTInterface PIdent
| MTConcrete PIdent PIdent
| MTInstance PIdent PIdent
| MTTransfer PIdent Open Open
deriving (Eq,Ord,Show)
data ModBody =
MBody Extend Opens [TopDef]
| MNoBody [Included]
| MWith Included [Open]
| MWithBody Included [Open] Opens [TopDef]
| MWithE [Included] Included [Open]
| MWithEBody [Included] Included [Open] Opens [TopDef]
| MReuse PIdent
| MUnion [Included]
deriving (Eq,Ord,Show)
data Extend =
Ext [Included]
| NoExt
deriving (Eq,Ord,Show)
data Opens =
NoOpens
| OpenIn [Open]
deriving (Eq,Ord,Show)
data Open =
OName PIdent
| OQualQO QualOpen PIdent
| OQual QualOpen PIdent PIdent
deriving (Eq,Ord,Show)
data ComplMod =
CMCompl
| CMIncompl
deriving (Eq,Ord,Show)
data QualOpen =
QOCompl
| QOIncompl
| QOInterface
deriving (Eq,Ord,Show)
data Included =
IAll PIdent
| ISome PIdent [PIdent]
| IMinus PIdent [PIdent]
deriving (Eq,Ord,Show)
data Def =
DDecl [Name] Exp
| DDef [Name] Exp
| DPatt Name [Patt] Exp
| DFull [Name] Exp Exp
deriving (Eq,Ord,Show)
data TopDef =
DefCat [CatDef]
| DefFun [FunDef]
| DefFunData [FunDef]
| DefDef [Def]
| DefData [DataDef]
| DefTrans [Def]
| DefPar [ParDef]
| DefOper [Def]
| DefLincat [PrintDef]
| DefLindef [Def]
| DefLin [Def]
| DefPrintCat [PrintDef]
| DefPrintFun [PrintDef]
| DefFlag [FlagDef]
| DefPrintOld [PrintDef]
| DefLintype [Def]
| DefPattern [Def]
| DefPackage PIdent [TopDef]
| DefVars [Def]
| DefTokenizer PIdent
deriving (Eq,Ord,Show)
data CatDef =
SimpleCatDef PIdent [DDecl]
| ListCatDef PIdent [DDecl]
| ListSizeCatDef PIdent [DDecl] Integer
deriving (Eq,Ord,Show)
data FunDef =
FunDef [PIdent] Exp
deriving (Eq,Ord,Show)
data DataDef =
DataDef PIdent [DataConstr]
deriving (Eq,Ord,Show)
data DataConstr =
DataId PIdent
| DataQId PIdent PIdent
deriving (Eq,Ord,Show)
data ParDef =
ParDefDir PIdent [ParConstr]
| ParDefIndir PIdent PIdent
| ParDefAbs PIdent
deriving (Eq,Ord,Show)
data ParConstr =
ParConstr PIdent [DDecl]
deriving (Eq,Ord,Show)
data PrintDef =
PrintDef [Name] Exp
deriving (Eq,Ord,Show)
data FlagDef =
FlagDef PIdent PIdent
deriving (Eq,Ord,Show)
data Name =
IdentName PIdent
| ListName PIdent
deriving (Eq,Ord,Show)
data LocDef =
LDDecl [PIdent] Exp
| LDDef [PIdent] Exp
| LDFull [PIdent] Exp Exp
deriving (Eq,Ord,Show)
data Exp =
EIdent PIdent
| EConstr PIdent
| ECons PIdent
| ESort Sort
| EString String
| EInt Integer
| EFloat Double
| EMeta
| EEmpty
| EData
| EList PIdent Exps
| EStrings String
| ERecord [LocDef]
| ETuple [TupleComp]
| EIndir PIdent
| ETyped Exp Exp
| EProj Exp Label
| EQConstr PIdent PIdent
| EQCons PIdent PIdent
| EApp Exp Exp
| ETable [Case]
| ETTable Exp [Case]
| EVTable Exp [Exp]
| ECase Exp [Case]
| EVariants [Exp]
| EPre Exp [Altern]
| EStrs [Exp]
| EConAt PIdent Exp
| EPatt Patt
| EPattType Exp
| ESelect Exp Exp
| ETupTyp Exp Exp
| EExtend Exp Exp
| EGlue Exp Exp
| EConcat Exp Exp
| EAbstr [Bind] Exp
| ECTable [Bind] Exp
| EProd Decl Exp
| ETType Exp Exp
| ELet [LocDef] Exp
| ELetb [LocDef] Exp
| EWhere Exp [LocDef]
| EEqs [Equation]
| EExample Exp String
| ELString LString
| ELin PIdent
deriving (Eq,Ord,Show)
data Exps =
NilExp
| ConsExp Exp Exps
deriving (Eq,Ord,Show)
data Patt =
PChar
| PChars String
| PMacro PIdent
| PM PIdent PIdent
| PW
| PV PIdent
| PCon PIdent
| PQ PIdent PIdent
| PInt Integer
| PFloat Double
| PStr String
| PR [PattAss]
| PTup [PattTupleComp]
| PC PIdent [Patt]
| PQC PIdent PIdent [Patt]
| PDisj Patt Patt
| PSeq Patt Patt
| PRep Patt
| PAs PIdent Patt
| PNeg Patt
deriving (Eq,Ord,Show)
data PattAss =
PA [PIdent] Patt
deriving (Eq,Ord,Show)
data Label =
LIdent PIdent
| LVar Integer
deriving (Eq,Ord,Show)
data Sort =
Sort_Type
| Sort_PType
| Sort_Tok
| Sort_Str
| Sort_Strs
deriving (Eq,Ord,Show)
data Bind =
BIdent PIdent
| BWild
deriving (Eq,Ord,Show)
data Decl =
DDec [Bind] Exp
| DExp Exp
deriving (Eq,Ord,Show)
data TupleComp =
TComp Exp
deriving (Eq,Ord,Show)
data PattTupleComp =
PTComp Patt
deriving (Eq,Ord,Show)
data Case =
Case Patt Exp
deriving (Eq,Ord,Show)
data Equation =
Equ [Patt] Exp
deriving (Eq,Ord,Show)
data Altern =
Alt Exp Exp
deriving (Eq,Ord,Show)
data DDecl =
DDDec [Bind] Exp
| DDExp Exp
deriving (Eq,Ord,Show)
data OldGrammar =
OldGr Include [TopDef]
deriving (Eq,Ord,Show)
data Include =
NoIncl
| Incl [FileName]
deriving (Eq,Ord,Show)
data FileName =
FString String
| FIdent PIdent
| FSlash FileName
| FDot FileName
| FMinus FileName
| FAddId PIdent FileName
deriving (Eq,Ord,Show)
module GF.Source.AbsGF where
-- Haskell module generated by the BNF converter
import qualified Data.ByteString.Char8 as BS
newtype LString = LString BS.ByteString deriving (Eq,Ord,Show)
newtype PIdent = PIdent ((Int,Int),BS.ByteString) deriving (Eq,Ord,Show)
data Grammar =
Gr [ModDef]
deriving (Eq,Ord,Show)
data ModDef =
MMain PIdent PIdent [ConcSpec]
| MModule ComplMod ModType ModBody
deriving (Eq,Ord,Show)
data ConcSpec =
ConcSpec PIdent ConcExp
deriving (Eq,Ord,Show)
data ConcExp =
ConcExp PIdent [Transfer]
deriving (Eq,Ord,Show)
data Transfer =
TransferIn Open
| TransferOut Open
deriving (Eq,Ord,Show)
data ModType =
MTAbstract PIdent
| MTResource PIdent
| MTInterface PIdent
| MTConcrete PIdent PIdent
| MTInstance PIdent PIdent
| MTTransfer PIdent Open Open
deriving (Eq,Ord,Show)
data ModBody =
MBody Extend Opens [TopDef]
| MNoBody [Included]
| MWith Included [Open]
| MWithBody Included [Open] Opens [TopDef]
| MWithE [Included] Included [Open]
| MWithEBody [Included] Included [Open] Opens [TopDef]
| MReuse PIdent
| MUnion [Included]
deriving (Eq,Ord,Show)
data Extend =
Ext [Included]
| NoExt
deriving (Eq,Ord,Show)
data Opens =
NoOpens
| OpenIn [Open]
deriving (Eq,Ord,Show)
data Open =
OName PIdent
| OQualQO QualOpen PIdent
| OQual QualOpen PIdent PIdent
deriving (Eq,Ord,Show)
data ComplMod =
CMCompl
| CMIncompl
deriving (Eq,Ord,Show)
data QualOpen =
QOCompl
| QOIncompl
| QOInterface
deriving (Eq,Ord,Show)
data Included =
IAll PIdent
| ISome PIdent [PIdent]
| IMinus PIdent [PIdent]
deriving (Eq,Ord,Show)
data Def =
DDecl [Name] Exp
| DDef [Name] Exp
| DPatt Name [Patt] Exp
| DFull [Name] Exp Exp
deriving (Eq,Ord,Show)
data TopDef =
DefCat [CatDef]
| DefFun [FunDef]
| DefFunData [FunDef]
| DefDef [Def]
| DefData [DataDef]
| DefTrans [Def]
| DefPar [ParDef]
| DefOper [Def]
| DefLincat [PrintDef]
| DefLindef [Def]
| DefLin [Def]
| DefPrintCat [PrintDef]
| DefPrintFun [PrintDef]
| DefFlag [FlagDef]
| DefPrintOld [PrintDef]
| DefLintype [Def]
| DefPattern [Def]
| DefPackage PIdent [TopDef]
| DefVars [Def]
| DefTokenizer PIdent
deriving (Eq,Ord,Show)
data CatDef =
SimpleCatDef PIdent [DDecl]
| ListCatDef PIdent [DDecl]
| ListSizeCatDef PIdent [DDecl] Integer
deriving (Eq,Ord,Show)
data FunDef =
FunDef [PIdent] Exp
deriving (Eq,Ord,Show)
data DataDef =
DataDef PIdent [DataConstr]
deriving (Eq,Ord,Show)
data DataConstr =
DataId PIdent
| DataQId PIdent PIdent
deriving (Eq,Ord,Show)
data ParDef =
ParDefDir PIdent [ParConstr]
| ParDefIndir PIdent PIdent
| ParDefAbs PIdent
deriving (Eq,Ord,Show)
data ParConstr =
ParConstr PIdent [DDecl]
deriving (Eq,Ord,Show)
data PrintDef =
PrintDef [Name] Exp
deriving (Eq,Ord,Show)
data FlagDef =
FlagDef PIdent PIdent
deriving (Eq,Ord,Show)
data Name =
IdentName PIdent
| ListName PIdent
deriving (Eq,Ord,Show)
data LocDef =
LDDecl [PIdent] Exp
| LDDef [PIdent] Exp
| LDFull [PIdent] Exp Exp
deriving (Eq,Ord,Show)
data Exp =
EIdent PIdent
| EConstr PIdent
| ECons PIdent
| ESort Sort
| EString String
| EInt Integer
| EFloat Double
| EMeta
| EEmpty
| EData
| EList PIdent Exps
| EStrings String
| ERecord [LocDef]
| ETuple [TupleComp]
| EIndir PIdent
| ETyped Exp Exp
| EProj Exp Label
| EQConstr PIdent PIdent
| EQCons PIdent PIdent
| EApp Exp Exp
| ETable [Case]
| ETTable Exp [Case]
| EVTable Exp [Exp]
| ECase Exp [Case]
| EVariants [Exp]
| EPre Exp [Altern]
| EStrs [Exp]
| EConAt PIdent Exp
| EPatt Patt
| EPattType Exp
| ESelect Exp Exp
| ETupTyp Exp Exp
| EExtend Exp Exp
| EGlue Exp Exp
| EConcat Exp Exp
| EAbstr [Bind] Exp
| ECTable [Bind] Exp
| EProd Decl Exp
| ETType Exp Exp
| ELet [LocDef] Exp
| ELetb [LocDef] Exp
| EWhere Exp [LocDef]
| EEqs [Equation]
| EExample Exp String
| ELString LString
| ELin PIdent
deriving (Eq,Ord,Show)
data Exps =
NilExp
| ConsExp Exp Exps
deriving (Eq,Ord,Show)
data Patt =
PChar
| PChars String
| PMacro PIdent
| PM PIdent PIdent
| PW
| PV PIdent
| PCon PIdent
| PQ PIdent PIdent
| PInt Integer
| PFloat Double
| PStr String
| PR [PattAss]
| PTup [PattTupleComp]
| PC PIdent [Patt]
| PQC PIdent PIdent [Patt]
| PDisj Patt Patt
| PSeq Patt Patt
| PRep Patt
| PAs PIdent Patt
| PNeg Patt
deriving (Eq,Ord,Show)
data PattAss =
PA [PIdent] Patt
deriving (Eq,Ord,Show)
data Label =
LIdent PIdent
| LVar Integer
deriving (Eq,Ord,Show)
data Sort =
Sort_Type
| Sort_PType
| Sort_Tok
| Sort_Str
| Sort_Strs
deriving (Eq,Ord,Show)
data Bind =
BIdent PIdent
| BWild
deriving (Eq,Ord,Show)
data Decl =
DDec [Bind] Exp
| DExp Exp
deriving (Eq,Ord,Show)
data TupleComp =
TComp Exp
deriving (Eq,Ord,Show)
data PattTupleComp =
PTComp Patt
deriving (Eq,Ord,Show)
data Case =
Case Patt Exp
deriving (Eq,Ord,Show)
data Equation =
Equ [Patt] Exp
deriving (Eq,Ord,Show)
data Altern =
Alt Exp Exp
deriving (Eq,Ord,Show)
data DDecl =
DDDec [Bind] Exp
| DDExp Exp
deriving (Eq,Ord,Show)
data OldGrammar =
OldGr Include [TopDef]
deriving (Eq,Ord,Show)
data Include =
NoIncl
| Incl [FileName]
deriving (Eq,Ord,Show)
data FileName =
FString String
| FIdent PIdent
| FSlash FileName
| FDot FileName
| FMinus FileName
| FAddId PIdent FileName
deriving (Eq,Ord,Show)

52
src-3.0/GF/Source/ErrM.hs
View File

@@ -1,26 +1,26 @@
-- BNF Converter: Error Monad
-- Copyright (C) 2004 Author: Aarne Ranta
-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
module GF.Source.ErrM where
-- the Error monad: like Maybe type with error msgs
import Control.Monad (MonadPlus(..), liftM)
data Err a = Ok a | Bad String
deriving (Read, Show, Eq, Ord)
instance Monad Err where
return = Ok
fail = Bad
Ok a >>= f = f a
Bad s >>= f = Bad s
instance Functor Err where
fmap = liftM
instance MonadPlus Err where
mzero = Bad "Err.mzero"
mplus (Bad _) y = y
mplus x _ = x
-- BNF Converter: Error Monad
-- Copyright (C) 2004 Author: Aarne Ranta
-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
module GF.Source.ErrM where
-- the Error monad: like Maybe type with error msgs
import Control.Monad (MonadPlus(..), liftM)
data Err a = Ok a | Bad String
deriving (Read, Show, Eq, Ord)
instance Monad Err where
return = Ok
fail = Bad
Ok a >>= f = f a
Bad s >>= f = Bad s
instance Functor Err where
fmap = liftM
instance MonadPlus Err where
mzero = Bad "Err.mzero"
mplus (Bad _) y = y
mplus x _ = x

1
src-3.0/GF/Source/GF.cf
View File

@@ -5,6 +5,7 @@
entrypoints Grammar, ModDef,
OldGrammar, --%
ModHeader,
Exp ; -- let's see if more are needed
comment "--" ;

32
src-3.0/GF/Source/GrammarToSource.hs
View File

@@ -21,10 +21,12 @@ module GF.Source.GrammarToSource ( trGrammar,
import GF.Data.Operations
import GF.Grammar.Grammar
import GF.Grammar.Predef
import GF.Infra.Modules
import GF.Infra.Option
import qualified GF.Source.AbsGF as P
import GF.Infra.Ident
import qualified Data.ByteString.Char8 as BS
-- | AR 13\/5\/2003
--
@@ -96,7 +98,7 @@ trAnyDef (i,info) = let i' = tri i in case info of
ResOverload tysts ->
[P.DefOper [P.DDef [mkName i'] (
P.EApp (P.EIdent $ tri $ identC "overload")
P.EApp (P.EIdent $ tri $ cOverload)
(P.ERecord [P.LDFull [i'] (trt ty) (trt fu) | (ty,fu) <- tysts]))]]
CncCat (Yes ty) Nope _ ->
@@ -131,7 +133,7 @@ trPerh p = case p of
trFlag :: Option -> P.TopDef
trFlag o = case o of
Opt (f,[x]) -> P.DefFlag [P.FlagDef (tri $ identC f) (tri $ identC x)]
Opt (f,[x]) -> P.DefFlag [P.FlagDef (tri $ identC (BS.pack f)) (tri $ identC (BS.pack x))]
_ -> P.DefFlag [] --- warning?
trt :: Term -> P.Exp
@@ -139,14 +141,12 @@ trt trm = case trm of
Vr s -> P.EIdent $ tri s
Cn s -> P.ECons $ tri s
Con s -> P.EConstr $ tri s
Sort s -> P.ESort $ case s of
"Type" -> P.Sort_Type
"PType" -> P.Sort_PType
"Tok" -> P.Sort_Tok
"Str" -> P.Sort_Str
"Strs" -> P.Sort_Strs
_ -> error $ "not yet sort " +++ show trm ----
Sort s -> P.ESort $! if s == cType then P.Sort_Type else
if s == cPType then P.Sort_PType else
if s == cTok then P.Sort_Tok else
if s == cStr then P.Sort_Str else
if s == cStrs then P.Sort_Strs else
error $ "not yet sort " +++ show trm
App c a -> P.EApp (trt c) (trt a)
Abs x b -> P.EAbstr [trb x] (trt b)
Eqs pts -> P.EEqs [P.Equ (map trp ps) (trt t) | (ps,t) <- pts]
@@ -210,7 +210,7 @@ trp p = case p of
PC c a -> P.PC (tri c) (map trp a)
PP p c [] -> P.PQ (tri p) (tri c)
PP p c a -> P.PQC (tri p) (tri c) (map trp a)
PR r -> P.PR [P.PA [tri $ trLabelIdent l] (trp p) | (l,p) <- r]
PR r -> P.PR [P.PA [tri $ label2ident l] (trp p) | (l,p) <- r]
PString s -> P.PStr s
PInt i -> P.PInt i
PFloat i -> P.PFloat i
@@ -230,9 +230,9 @@ trp p = case p of
trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty
where
t' = trt t
x = [tri $ trLabelIdent lab]
x = [tri $ label2ident lab]
trLabelling (lab,ty) = P.LDDecl [tri $ trLabelIdent lab] (trt ty)
trLabelling (lab,ty) = P.LDDecl [tri $ label2ident lab] (trt ty)
trCase (patt, trm) = P.Case (trp patt) (trt trm)
trCases (patts,trm) = P.Case (foldl1 P.PDisj (map trp patts)) (trt trm)
@@ -240,7 +240,7 @@ trCases (patts,trm) = P.Case (foldl1 P.PDisj (map trp patts)) (trt trm)
trDecl (x,ty) = P.DDDec [trb x] (trt ty)
tri :: Ident -> P.PIdent
tri = ppIdent . prIdent
tri = ppIdent . ident2bs
ppIdent i = P.PIdent ((0,0),i)
@@ -251,9 +251,5 @@ trLabel i = case i of
LIdent s -> P.LIdent $ ppIdent s
LVar i -> P.LVar $ toInteger i
trLabelIdent i = identC $ case i of
LIdent s -> s
LVar i -> "v" ++ show i --- should not happen
mkName :: P.PIdent -> P.Name
mkName = P.IdentName

695
src-3.0/GF/Source/LexGF.hs
View File

File diff suppressed because one or more lines are too long

281
src-3.0/GF/Source/LexGF.x
View File

@@ -1,137 +1,144 @@
-- -*- haskell -*-
-- This Alex file was machine-generated by the BNF converter
{
module LexGF where
import ErrM
import SharedString
}
$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME
$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME
$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME
$d = [0-9] -- digit
$i = [$l $d _ '] -- identifier character
$u = [\0-\255] -- universal: any character
@rsyms = -- reserved words consisting of special symbols
\; | \= | \{ | \} | \( | \) | \: | \- \> | \* \* | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \! | \* | \+ | \+ \+ | \\ | \= \> | \_ | \$ | \/
:-
"--" [.]* ; -- Toss single line comments
"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;
$white+ ;
@rsyms { tok (\p s -> PT p (TS $ share s)) }
\' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent (T_LString . share) s)) }
$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
$d+ { tok (\p s -> PT p (TI $ share s)) }
$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) }
{
tok f p s = f p s
share :: String -> String
share = shareString
data Tok =
TS !String -- reserved words
| TL !String -- string literals
| TI !String -- integer literals
| TV !String -- identifiers
| TD !String -- double precision float literals
| TC !String -- character literals
| T_LString !String
deriving (Eq,Show,Ord)
data Token =
PT Posn Tok
| Err Posn
deriving (Eq,Show,Ord)
tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
tokenPos _ = "end of file"
posLineCol (Pn _ l c) = (l,c)
mkPosToken t@(PT p _) = (posLineCol p, prToken t)
prToken t = case t of
PT _ (TS s) -> s
PT _ (TI s) -> s
PT _ (TV s) -> s
PT _ (TD s) -> s
PT _ (TC s) -> s
PT _ (T_LString s) -> s
_ -> show t
data BTree = N | B String Tok BTree BTree deriving (Show)
eitherResIdent :: (String -> Tok) -> String -> Tok
eitherResIdent tv s = treeFind resWords
where
treeFind N = tv s
treeFind (B a t left right) | s < a = treeFind left
| s > a = treeFind right
| s == a = t
resWords = b "lincat" (b "def" (b "Type" (b "Str" (b "PType" (b "Lin" N N) N) (b "Tok" (b "Strs" N N) N)) (b "cat" (b "case" (b "abstract" N N) N) (b "data" (b "concrete" N N) N))) (b "include" (b "fun" (b "fn" (b "flags" N N) N) (b "in" (b "grammar" N N) N)) (b "interface" (b "instance" (b "incomplete" N N) N) (b "lin" (b "let" N N) N)))) (b "resource" (b "out" (b "of" (b "lintype" (b "lindef" N N) N) (b "oper" (b "open" N N) N)) (b "pattern" (b "param" (b "package" N N) N) (b "printname" (b "pre" N N) N))) (b "union" (b "table" (b "strs" (b "reuse" N N) N) (b "transfer" (b "tokenizer" N N) N)) (b "where" (b "variants" (b "var" N N) N) (b "with" N N))))
where b s = B s (TS s)
unescapeInitTail :: String -> String
unescapeInitTail = unesc . tail where
unesc s = case s of
'\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
'\\':'n':cs -> '\n' : unesc cs
'\\':'t':cs -> '\t' : unesc cs
'"':[] -> []
c:cs -> c : unesc cs
_ -> []
-------------------------------------------------------------------
-- Alex wrapper code.
-- A modified "posn" wrapper.
-------------------------------------------------------------------
data Posn = Pn !Int !Int !Int
deriving (Eq, Show,Ord)
alexStartPos :: Posn
alexStartPos = Pn 0 1 1
alexMove :: Posn -> Char -> Posn
alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)
alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1
alexMove (Pn a l c) _ = Pn (a+1) l (c+1)
type AlexInput = (Posn, -- current position,
Char, -- previous char
String) -- current input string
tokens :: String -> [Token]
tokens str = go (alexStartPos, '\n', str)
where
go :: (Posn, Char, String) -> [Token]
go inp@(pos, _, str) =
case alexScan inp 0 of
AlexEOF -> []
AlexError (pos, _, _) -> fail $ show pos ++ ": lexical error"
AlexSkip inp' len -> go inp'
AlexToken inp' len act -> act pos (take len str) : (go inp')
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar (p, c, []) = Nothing
alexGetChar (p, _, (c:s)) =
let p' = alexMove p c
in p' `seq` Just (c, (p', c, s))
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (p, c, s) = c
}
-- -*- haskell -*-
-- This Alex file was machine-generated by the BNF converter
{
{-# OPTIONS -fno-warn-incomplete-patterns #-}
module GF.Source.LexGF where
import GF.Source.SharedString
import qualified Data.ByteString.Char8 as BS
}
$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME
$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME
$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME
$d = [0-9] -- digit
$i = [$l $d _ '] -- identifier character
$u = [\0-\255] -- universal: any character
@rsyms = -- symbols and non-identifier-like reserved words
\; | \= | \{ | \} | \( | \) | \* \* | \: | \- \> | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \= \> | \_ | \$ | \/
:-
"--" [.]* ; -- Toss single line comments
"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;
$white+ ;
@rsyms { tok (\p s -> PT p (eitherResIdent (T_PIdent . share) s)) }
\' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent (T_LString . share) s)) }
(\_ | $l)($l | $d | \_ | \')* { tok (\p s -> PT p (eitherResIdent (T_PIdent . share) s)) }
$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
$d+ { tok (\p s -> PT p (TI $ share s)) }
$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) }
{
tok f p s = f p s
share :: BS.ByteString -> BS.ByteString
share = shareString
data Tok =
TS !BS.ByteString !Int -- reserved words and symbols
| TL !BS.ByteString -- string literals
| TI !BS.ByteString -- integer literals
| TV !BS.ByteString -- identifiers
| TD !BS.ByteString -- double precision float literals
| TC !BS.ByteString -- character literals
| T_LString !BS.ByteString
| T_PIdent !BS.ByteString
deriving (Eq,Show,Ord)
data Token =
PT Posn Tok
| Err Posn
deriving (Eq,Show,Ord)
tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
tokenPos _ = "end of file"
posLineCol (Pn _ l c) = (l,c)
mkPosToken t@(PT p _) = (posLineCol p, prToken t)
prToken t = case t of
PT _ (TS s _) -> s
PT _ (TL s) -> s
PT _ (TI s) -> s
PT _ (TV s) -> s
PT _ (TD s) -> s
PT _ (TC s) -> s
PT _ (T_LString s) -> s
PT _ (T_PIdent s) -> s
data BTree = N | B BS.ByteString Tok BTree BTree deriving (Show)
eitherResIdent :: (BS.ByteString -> Tok) -> BS.ByteString -> Tok
eitherResIdent tv s = treeFind resWords
where
treeFind N = tv s
treeFind (B a t left right) | s < a = treeFind left
| s > a = treeFind right
| s == a = t
resWords = b "def" 39 (b "=>" 20 (b "++" 10 (b "(" 5 (b "$" 3 (b "#" 2 (b "!" 1 N N) N) (b "%" 4 N N)) (b "**" 8 (b "*" 7 (b ")" 6 N N) N) (b "+" 9 N N))) (b "/" 15 (b "->" 13 (b "-" 12 (b "," 11 N N) N) (b "." 14 N N)) (b "<" 18 (b ";" 17 (b ":" 16 N N) N) (b "=" 19 N N)))) (b "[" 30 (b "PType" 25 (b "@" 23 (b "?" 22 (b ">" 21 N N) N) (b "Lin" 24 N N)) (b "Tok" 28 (b "Strs" 27 (b "Str" 26 N N) N) (b "Type" 29 N N))) (b "case" 35 (b "_" 33 (b "]" 32 (b "\\" 31 N N) N) (b "abstract" 34 N N)) (b "concrete" 37 (b "cat" 36 N N) (b "data" 38 N N))))) (b "package" 58 (b "let" 49 (b "in" 44 (b "fun" 42 (b "fn" 41 (b "flags" 40 N N) N) (b "grammar" 43 N N)) (b "instance" 47 (b "incomplete" 46 (b "include" 45 N N) N) (b "interface" 48 N N))) (b "of" 54 (b "lindef" 52 (b "lincat" 51 (b "lin" 50 N N) N) (b "lintype" 53 N N)) (b "oper" 56 (b "open" 55 N N) (b "out" 57 N N)))) (b "transfer" 68 (b "resource" 63 (b "pre" 61 (b "pattern" 60 (b "param" 59 N N) N) (b "printname" 62 N N)) (b "table" 66 (b "strs" 65 (b "reuse" 64 N N) N) (b "tokenizer" 67 N N))) (b "with" 73 (b "variants" 71 (b "var" 70 (b "union" 69 N N) N) (b "where" 72 N N)) (b "|" 75 (b "{" 74 N N) (b "}" 76 N N)))))
where b s n = let bs = BS.pack s
in B bs (TS bs n)
unescapeInitTail :: BS.ByteString -> BS.ByteString
unescapeInitTail = BS.pack . unesc . tail . BS.unpack where
unesc s = case s of
'\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
'\\':'n':cs -> '\n' : unesc cs
'\\':'t':cs -> '\t' : unesc cs
'"':[] -> []
c:cs -> c : unesc cs
_ -> []
-------------------------------------------------------------------
-- Alex wrapper code.
-- A modified "posn" wrapper.
-------------------------------------------------------------------
data Posn = Pn !Int !Int !Int
deriving (Eq, Show,Ord)
alexStartPos :: Posn
alexStartPos = Pn 0 1 1
alexMove :: Posn -> Char -> Posn
alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)
alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1
alexMove (Pn a l c) _ = Pn (a+1) l (c+1)
type AlexInput = (Posn, -- current position,
Char, -- previous char
BS.ByteString) -- current input string
tokens :: BS.ByteString -> [Token]
tokens str = go (alexStartPos, '\n', str)
where
go :: AlexInput -> [Token]
go inp@(pos, _, str) =
case alexScan inp 0 of
AlexEOF -> []
AlexError (pos, _, _) -> [Err pos]
AlexSkip inp' len -> go inp'
AlexToken inp' len act -> act pos (BS.take len str) : (go inp')
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar (p, _, s) =
case BS.uncons s of
Nothing -> Nothing
Just (c,s) ->
let p' = alexMove p c
in p' `seq` Just (c, (p', c, s))
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (p, c, s) = c
}

6596
src-3.0/GF/Source/ParGF.hs
View File

File diff suppressed because it is too large Load Diff

1284
src-3.0/GF/Source/ParGF.y
View File

File diff suppressed because it is too large Load Diff

1066
src-3.0/GF/Source/PrintGF.hs
View File

File diff suppressed because it is too large Load Diff

745
src-3.0/GF/Source/SkelGF.hs
View File

@@ -1,364 +1,381 @@
module GF.Source.SkelGF where
-- Haskell module generated by the BNF converter
import GF.Source.AbsGF
import GF.Source.ErrM
type Result = Err String
failure :: Show a => a -> Result
failure x = Bad $ "Undefined case: " ++ show x
transLString :: LString -> Result
transLString x = case x of
LString str -> failure x
transPIdent :: PIdent -> Result
transPIdent x = case x of
PIdent str -> failure x
transGrammar :: Grammar -> Result
transGrammar x = case x of
Gr moddefs -> failure x
transModDef :: ModDef -> Result
transModDef x = case x of
MMain pident0 pident concspecs -> failure x
MModule complmod modtype modbody -> failure x
transConcSpec :: ConcSpec -> Result
transConcSpec x = case x of
ConcSpec pident concexp -> failure x
transConcExp :: ConcExp -> Result
transConcExp x = case x of
ConcExp pident transfers -> failure x
transTransfer :: Transfer -> Result
transTransfer x = case x of
TransferIn open -> failure x
TransferOut open -> failure x
transModType :: ModType -> Result
transModType x = case x of
MTAbstract pident -> failure x
MTResource pident -> failure x
MTInterface pident -> failure x
MTConcrete pident0 pident -> failure x
MTInstance pident0 pident -> failure x
MTTransfer pident open0 open -> failure x
transModBody :: ModBody -> Result
transModBody x = case x of
MBody extend opens topdefs -> failure x
MNoBody includeds -> failure x
MWith included opens -> failure x
MWithBody included opens0 opens topdefs -> failure x
MWithE includeds included opens -> failure x
MWithEBody includeds included opens0 opens topdefs -> failure x
MReuse pident -> failure x
MUnion includeds -> failure x
transExtend :: Extend -> Result
transExtend x = case x of
Ext includeds -> failure x
NoExt -> failure x
transOpens :: Opens -> Result
transOpens x = case x of
NoOpens -> failure x
OpenIn opens -> failure x
transOpen :: Open -> Result
transOpen x = case x of
OName pident -> failure x
OQualQO qualopen pident -> failure x
OQual qualopen pident0 pident -> failure x
transComplMod :: ComplMod -> Result
transComplMod x = case x of
CMCompl -> failure x
CMIncompl -> failure x
transQualOpen :: QualOpen -> Result
transQualOpen x = case x of
QOCompl -> failure x
QOIncompl -> failure x
QOInterface -> failure x
transIncluded :: Included -> Result
transIncluded x = case x of
IAll pident -> failure x
ISome pident pidents -> failure x
IMinus pident pidents -> failure x
transDef :: Def -> Result
transDef x = case x of
DDecl names exp -> failure x
DDef names exp -> failure x
DPatt name patts exp -> failure x
DFull names exp0 exp -> failure x
transTopDef :: TopDef -> Result
transTopDef x = case x of
DefCat catdefs -> failure x
DefFun fundefs -> failure x
DefFunData fundefs -> failure x
DefDef defs -> failure x
DefData datadefs -> failure x
DefTrans defs -> failure x
DefPar pardefs -> failure x
DefOper defs -> failure x
DefLincat printdefs -> failure x
DefLindef defs -> failure x
DefLin defs -> failure x
DefPrintCat printdefs -> failure x
DefPrintFun printdefs -> failure x
DefFlag flagdefs -> failure x
DefPrintOld printdefs -> failure x
DefLintype defs -> failure x
DefPattern defs -> failure x
DefPackage pident topdefs -> failure x
DefVars defs -> failure x
DefTokenizer pident -> failure x
transCatDef :: CatDef -> Result
transCatDef x = case x of
SimpleCatDef pident ddecls -> failure x
ListCatDef pident ddecls -> failure x
ListSizeCatDef pident ddecls n -> failure x
transFunDef :: FunDef -> Result
transFunDef x = case x of
FunDef pidents exp -> failure x
transDataDef :: DataDef -> Result
transDataDef x = case x of
DataDef pident dataconstrs -> failure x
transDataConstr :: DataConstr -> Result
transDataConstr x = case x of
DataId pident -> failure x
DataQId pident0 pident -> failure x
transParDef :: ParDef -> Result
transParDef x = case x of
ParDefDir pident parconstrs -> failure x
ParDefIndir pident0 pident -> failure x
ParDefAbs pident -> failure x
transParConstr :: ParConstr -> Result
transParConstr x = case x of
ParConstr pident ddecls -> failure x
transPrintDef :: PrintDef -> Result
transPrintDef x = case x of
PrintDef names exp -> failure x
transFlagDef :: FlagDef -> Result
transFlagDef x = case x of
FlagDef pident0 pident -> failure x
transName :: Name -> Result
transName x = case x of
IdentName pident -> failure x
ListName pident -> failure x
transLocDef :: LocDef -> Result
transLocDef x = case x of
LDDecl pidents exp -> failure x
LDDef pidents exp -> failure x
LDFull pidents exp0 exp -> failure x
transExp :: Exp -> Result
transExp x = case x of
EIdent pident -> failure x
EConstr pident -> failure x
ECons pident -> failure x
ESort sort -> failure x
EString str -> failure x
EInt n -> failure x
EFloat d -> failure x
EMeta -> failure x
EEmpty -> failure x
EData -> failure x
EList pident exps -> failure x
EStrings str -> failure x
ERecord locdefs -> failure x
ETuple tuplecomps -> failure x
EIndir pident -> failure x
ETyped exp0 exp -> failure x
EProj exp label -> failure x
EQConstr pident0 pident -> failure x
EQCons pident0 pident -> failure x
EApp exp0 exp -> failure x
ETable cases -> failure x
ETTable exp cases -> failure x
EVTable exp exps -> failure x
ECase exp cases -> failure x
EVariants exps -> failure x
EPre exp alterns -> failure x
EStrs exps -> failure x
EConAt pident exp -> failure x
EPatt patt -> failure x
EPattType exp -> failure x
ESelect exp0 exp -> failure x
ETupTyp exp0 exp -> failure x
EExtend exp0 exp -> failure x
EGlue exp0 exp -> failure x
EConcat exp0 exp -> failure x
EAbstr binds exp -> failure x
ECTable binds exp -> failure x
EProd decl exp -> failure x
ETType exp0 exp -> failure x
ELet locdefs exp -> failure x
ELetb locdefs exp -> failure x
EWhere exp locdefs -> failure x
EEqs equations -> failure x
EExample exp str -> failure x
ELString lstring -> failure x
ELin pident -> failure x
transExps :: Exps -> Result
transExps x = case x of
NilExp -> failure x
ConsExp exp exps -> failure x
transPatt :: Patt -> Result
transPatt x = case x of
PChar -> failure x
PChars str -> failure x
PMacro pident -> failure x
PM pident0 pident -> failure x
PW -> failure x
PV pident -> failure x
PCon pident -> failure x
PQ pident0 pident -> failure x
PInt n -> failure x
PFloat d -> failure x
PStr str -> failure x
PR pattasss -> failure x
PTup patttuplecomps -> failure x
PC pident patts -> failure x
PQC pident0 pident patts -> failure x
PDisj patt0 patt -> failure x
PSeq patt0 patt -> failure x
PRep patt -> failure x
PAs pident patt -> failure x
PNeg patt -> failure x
transPattAss :: PattAss -> Result
transPattAss x = case x of
PA pidents patt -> failure x
transLabel :: Label -> Result
transLabel x = case x of
LIdent pident -> failure x
LVar n -> failure x
transSort :: Sort -> Result
transSort x = case x of
Sort_Type -> failure x
Sort_PType -> failure x
Sort_Tok -> failure x
Sort_Str -> failure x
Sort_Strs -> failure x
transBind :: Bind -> Result
transBind x = case x of
BIdent pident -> failure x
BWild -> failure x
transDecl :: Decl -> Result
transDecl x = case x of
DDec binds exp -> failure x
DExp exp -> failure x
transTupleComp :: TupleComp -> Result
transTupleComp x = case x of
TComp exp -> failure x
transPattTupleComp :: PattTupleComp -> Result
transPattTupleComp x = case x of
PTComp patt -> failure x
transCase :: Case -> Result
transCase x = case x of
Case patt exp -> failure x
transEquation :: Equation -> Result
transEquation x = case x of
Equ patts exp -> failure x
transAltern :: Altern -> Result
transAltern x = case x of
Alt exp0 exp -> failure x
transDDecl :: DDecl -> Result
transDDecl x = case x of
DDDec binds exp -> failure x
DDExp exp -> failure x
transOldGrammar :: OldGrammar -> Result
transOldGrammar x = case x of
OldGr include topdefs -> failure x
transInclude :: Include -> Result
transInclude x = case x of
NoIncl -> failure x
Incl filenames -> failure x
transFileName :: FileName -> Result
transFileName x = case x of
FString str -> failure x
FIdent pident -> failure x
FSlash filename -> failure x
FDot filename -> failure x
FMinus filename -> failure x
FAddId pident filename -> failure x
module GF.Source.SkelGF where
-- Haskell module generated by the BNF converter
import GF.Source.AbsGF
import GF.Source.ErrM
type Result = Err String
failure :: Show a => a -> Result
failure x = Bad $ "Undefined case: " ++ show x
transLString :: LString -> Result
transLString x = case x of
LString str -> failure x
transPIdent :: PIdent -> Result
transPIdent x = case x of
PIdent str -> failure x
transGrammar :: Grammar -> Result
transGrammar x = case x of
Gr moddefs -> failure x
transModDef :: ModDef -> Result
transModDef x = case x of
MMain pident0 pident concspecs -> failure x
MModule complmod modtype modbody -> failure x
transConcSpec :: ConcSpec -> Result
transConcSpec x = case x of
ConcSpec pident concexp -> failure x
transConcExp :: ConcExp -> Result
transConcExp x = case x of
ConcExp pident transfers -> failure x
transTransfer :: Transfer -> Result
transTransfer x = case x of
TransferIn open -> failure x
TransferOut open -> failure x
transModHeader :: ModHeader -> Result
transModHeader x = case x of
MModule2 complmod modtype modheaderbody -> failure x
transModHeaderBody :: ModHeaderBody -> Result
transModHeaderBody x = case x of
MBody2 extend opens -> failure x
MNoBody2 includeds -> failure x
MWith2 included opens -> failure x
MWithBody2 included opens0 opens -> failure x
MWithE2 includeds included opens -> failure x
MWithEBody2 includeds included opens0 opens -> failure x
MReuse2 pident -> failure x
MUnion2 includeds -> failure x
transModType :: ModType -> Result
transModType x = case x of
MTAbstract pident -> failure x
MTResource pident -> failure x
MTInterface pident -> failure x
MTConcrete pident0 pident -> failure x
MTInstance pident0 pident -> failure x
MTTransfer pident open0 open -> failure x
transModBody :: ModBody -> Result
transModBody x = case x of
MBody extend opens topdefs -> failure x
MNoBody includeds -> failure x
MWith included opens -> failure x
MWithBody included opens0 opens topdefs -> failure x
MWithE includeds included opens -> failure x
MWithEBody includeds included opens0 opens topdefs -> failure x
MReuse pident -> failure x
MUnion includeds -> failure x
transExtend :: Extend -> Result
transExtend x = case x of
Ext includeds -> failure x
NoExt -> failure x
transOpens :: Opens -> Result
transOpens x = case x of
NoOpens -> failure x
OpenIn opens -> failure x
transOpen :: Open -> Result
transOpen x = case x of
OName pident -> failure x
OQualQO qualopen pident -> failure x
OQual qualopen pident0 pident -> failure x
transComplMod :: ComplMod -> Result
transComplMod x = case x of
CMCompl -> failure x
CMIncompl -> failure x
transQualOpen :: QualOpen -> Result
transQualOpen x = case x of
QOCompl -> failure x
QOIncompl -> failure x
QOInterface -> failure x
transIncluded :: Included -> Result
transIncluded x = case x of
IAll pident -> failure x
ISome pident pidents -> failure x
IMinus pident pidents -> failure x
transDef :: Def -> Result
transDef x = case x of
DDecl names exp -> failure x
DDef names exp -> failure x
DPatt name patts exp -> failure x
DFull names exp0 exp -> failure x
transTopDef :: TopDef -> Result
transTopDef x = case x of
DefCat catdefs -> failure x
DefFun fundefs -> failure x
DefFunData fundefs -> failure x
DefDef defs -> failure x
DefData datadefs -> failure x
DefTrans defs -> failure x
DefPar pardefs -> failure x
DefOper defs -> failure x
DefLincat printdefs -> failure x
DefLindef defs -> failure x
DefLin defs -> failure x
DefPrintCat printdefs -> failure x
DefPrintFun printdefs -> failure x
DefFlag flagdefs -> failure x
DefPrintOld printdefs -> failure x
DefLintype defs -> failure x
DefPattern defs -> failure x
DefPackage pident topdefs -> failure x
DefVars defs -> failure x
DefTokenizer pident -> failure x
transCatDef :: CatDef -> Result
transCatDef x = case x of
SimpleCatDef pident ddecls -> failure x
ListCatDef pident ddecls -> failure x
ListSizeCatDef pident ddecls n -> failure x
transFunDef :: FunDef -> Result
transFunDef x = case x of
FunDef pidents exp -> failure x
transDataDef :: DataDef -> Result
transDataDef x = case x of
DataDef pident dataconstrs -> failure x
transDataConstr :: DataConstr -> Result
transDataConstr x = case x of
DataId pident -> failure x
DataQId pident0 pident -> failure x
transParDef :: ParDef -> Result
transParDef x = case x of
ParDefDir pident parconstrs -> failure x
ParDefIndir pident0 pident -> failure x
ParDefAbs pident -> failure x
transParConstr :: ParConstr -> Result
transParConstr x = case x of
ParConstr pident ddecls -> failure x
transPrintDef :: PrintDef -> Result
transPrintDef x = case x of
PrintDef names exp -> failure x
transFlagDef :: FlagDef -> Result
transFlagDef x = case x of
FlagDef pident0 pident -> failure x
transName :: Name -> Result
transName x = case x of
IdentName pident -> failure x
ListName pident -> failure x
transLocDef :: LocDef -> Result
transLocDef x = case x of
LDDecl pidents exp -> failure x
LDDef pidents exp -> failure x
LDFull pidents exp0 exp -> failure x
transExp :: Exp -> Result
transExp x = case x of
EIdent pident -> failure x
EConstr pident -> failure x
ECons pident -> failure x
ESort sort -> failure x
EString str -> failure x
EInt n -> failure x
EFloat d -> failure x
EMeta -> failure x
EEmpty -> failure x
EData -> failure x
EList pident exps -> failure x
EStrings str -> failure x
ERecord locdefs -> failure x
ETuple tuplecomps -> failure x
EIndir pident -> failure x
ETyped exp0 exp -> failure x
EProj exp label -> failure x
EQConstr pident0 pident -> failure x
EQCons pident0 pident -> failure x
EApp exp0 exp -> failure x
ETable cases -> failure x
ETTable exp cases -> failure x
EVTable exp exps -> failure x
ECase exp cases -> failure x
EVariants exps -> failure x
EPre exp alterns -> failure x
EStrs exps -> failure x
EConAt pident exp -> failure x
EPatt patt -> failure x
EPattType exp -> failure x
ESelect exp0 exp -> failure x
ETupTyp exp0 exp -> failure x
EExtend exp0 exp -> failure x
EGlue exp0 exp -> failure x
EConcat exp0 exp -> failure x
EAbstr binds exp -> failure x
ECTable binds exp -> failure x
EProd decl exp -> failure x
ETType exp0 exp -> failure x
ELet locdefs exp -> failure x
ELetb locdefs exp -> failure x
EWhere exp locdefs -> failure x
EEqs equations -> failure x
EExample exp str -> failure x
ELString lstring -> failure x
ELin pident -> failure x
transExps :: Exps -> Result
transExps x = case x of
NilExp -> failure x
ConsExp exp exps -> failure x
transPatt :: Patt -> Result
transPatt x = case x of
PChar -> failure x
PChars str -> failure x
PMacro pident -> failure x
PM pident0 pident -> failure x
PW -> failure x
PV pident -> failure x
PCon pident -> failure x
PQ pident0 pident -> failure x
PInt n -> failure x
PFloat d -> failure x
PStr str -> failure x
PR pattasss -> failure x
PTup patttuplecomps -> failure x
PC pident patts -> failure x
PQC pident0 pident patts -> failure x
PDisj patt0 patt -> failure x
PSeq patt0 patt -> failure x
PRep patt -> failure x
PAs pident patt -> failure x
PNeg patt -> failure x
transPattAss :: PattAss -> Result
transPattAss x = case x of
PA pidents patt -> failure x
transLabel :: Label -> Result
transLabel x = case x of
LIdent pident -> failure x
LVar n -> failure x
transSort :: Sort -> Result
transSort x = case x of
Sort_Type -> failure x
Sort_PType -> failure x
Sort_Tok -> failure x
Sort_Str -> failure x
Sort_Strs -> failure x
transBind :: Bind -> Result
transBind x = case x of
BIdent pident -> failure x
BWild -> failure x
transDecl :: Decl -> Result
transDecl x = case x of
DDec binds exp -> failure x
DExp exp -> failure x
transTupleComp :: TupleComp -> Result
transTupleComp x = case x of
TComp exp -> failure x
transPattTupleComp :: PattTupleComp -> Result
transPattTupleComp x = case x of
PTComp patt -> failure x
transCase :: Case -> Result
transCase x = case x of
Case patt exp -> failure x
transEquation :: Equation -> Result
transEquation x = case x of
Equ patts exp -> failure x
transAltern :: Altern -> Result
transAltern x = case x of
Alt exp0 exp -> failure x
transDDecl :: DDecl -> Result
transDDecl x = case x of
DDDec binds exp -> failure x
DDExp exp -> failure x
transOldGrammar :: OldGrammar -> Result
transOldGrammar x = case x of
OldGr include topdefs -> failure x
transInclude :: Include -> Result
transInclude x = case x of
NoIncl -> failure x
Incl filenames -> failure x
transFileName :: FileName -> Result
transFileName x = case x of
FString str -> failure x
FIdent pident -> failure x
FSlash filename -> failure x
FDot filename -> failure x
FMinus filename -> failure x
FAddId pident filename -> failure x

58
src-3.0/GF/Source/SourceToGrammar.hs
View File

@@ -27,6 +27,7 @@ import qualified GF.Grammar.Macros as M
import qualified GF.Compile.Update as U
import qualified GF.Infra.Option as GO
import qualified GF.Compile.ModDeps as GD
import GF.Grammar.Predef
import GF.Infra.Ident
import GF.Source.AbsGF
import GF.Source.PrintGF
@@ -37,6 +38,7 @@ import GF.Infra.Option
import Control.Monad
import Data.Char
import Data.List (genericReplicate)
import qualified Data.ByteString.Char8 as BS
-- based on the skeleton Haskell module generated by the BNF converter
@@ -45,9 +47,6 @@ type Result = Err String
failure :: Show a => a -> Err b
failure x = Bad $ "Undefined case: " ++ show x
prPIdent :: PIdent -> String
prPIdent (PIdent (_,c)) = c
getIdentPos :: PIdent -> Err (Ident,Int)
getIdentPos x = case x of
PIdent ((line,_),c) -> return (IC c,line)
@@ -225,7 +224,7 @@ transAbsDef x = case x of
DefFunData fundefs -> do
fundefs' <- mapM transFunDef fundefs
returnl $
[(cat, G.AbsCat nope (yes [M.cn fun])) | (funs,typ) <- fundefs',
[(cat, G.AbsCat nope (yes [G.Cn fun])) | (funs,typ) <- fundefs',
fun <- funs,
Ok (_,cat) <- [M.valCat typ]
] ++
@@ -257,6 +256,9 @@ returnl = return . Left
transFlagDef :: FlagDef -> Err GO.Option
transFlagDef x = case x of
FlagDef f x -> return $ GO.Opt (prPIdent f,[prPIdent x])
where
prPIdent (PIdent (_,c)) = BS.unpack c
-- | Cat definitions can also return some fun defs
-- if it is a list category definition
@@ -280,7 +282,7 @@ transCatDef x = case x of
consId = mkConsId id'
catd0@(c,G.AbsCat (Yes cont0) _) <- cat li ddecls
let
catd = (c,G.AbsCat (Yes cont0) (Yes [M.cn baseId,M.cn consId]))
catd = (c,G.AbsCat (Yes cont0) (Yes [G.Cn baseId,G.Cn consId]))
cont = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont0]
xs = map (G.Vr . fst) cont
cd = M.mkDecl (M.mkApp (G.Vr id') xs)
@@ -290,7 +292,7 @@ transCatDef x = case x of
constyp = M.mkProdSimple (cont ++ [cd, M.mkDecl lc]) lc
consfund = (consId, G.AbsFun (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 (varX i) else x
transFunDef :: FunDef -> Err ([Ident], G.Type)
transFunDef x = case x of
@@ -434,10 +436,10 @@ transExp x = case x of
EQConstr m c -> liftM2 G.QC (transIdent m) (transIdent c)
EQCons m c -> liftM2 G.Q (transIdent m) (transIdent c)
EString str -> return $ G.K str
ESort sort -> liftM G.Sort $ transSort sort
ESort sort -> return $ G.Sort $ transSort sort
EInt n -> return $ G.EInt n
EFloat n -> return $ G.EFloat n
EMeta -> return $ M.meta $ M.int2meta 0
EMeta -> return $ G.Meta $ M.int2meta 0
EEmpty -> return G.Empty
-- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n)
EList i es -> do
@@ -499,7 +501,7 @@ transExp x = case x of
EPattType typ -> liftM G.EPattType (transExp typ)
EPatt patt -> liftM G.EPatt (transPatt patt)
ELString (LString str) -> return $ G.K str
ELString (LString str) -> return $ G.K (BS.unpack str) -- use the grammar encoding here
ELin id -> liftM G.LiT $ transIdent id
EEqs eqs -> liftM G.Eqs $ mapM transEquation eqs
@@ -527,10 +529,10 @@ erecord2term ds = do
(lab,(Just ty,Nothing)) -> mapM tryRT fs >>= return . Left
_ -> mapM tryR fs >>= return . Right
tryRT f = case f of
(lab,(Just ty,Nothing)) -> return (M.ident2label lab,ty)
(lab,(Just ty,Nothing)) -> return (G.ident2label lab,ty)
_ -> Bad $ "illegal record type field" +++ GP.prt (fst f) --- manifest fields ?!
tryR f = case f of
(lab,(mty, Just t)) -> return (M.ident2label lab,(mty,t))
(lab,(mty, Just t)) -> return (G.ident2label lab,(mty,t))
_ -> Bad $ "illegal record field" +++ GP.prt (fst f)
@@ -552,16 +554,16 @@ locdef2fields d = case d of
trLabel :: Label -> Err G.Label
trLabel x = case x of
-- this case is for bward compatibility and should be removed
LIdent (PIdent (_,'v':ds@(_:_))) | all isDigit ds -> return $ G.LVar $ readIntArg ds
LIdent (PIdent (_, s)) -> return $ G.LIdent s
LVar x -> return $ G.LVar $ fromInteger x
LVar x -> return $ G.LVar $ fromInteger x
transSort :: Sort -> Ident
transSort Sort_Type = cType
transSort Sort_PType = cPType
transSort Sort_Tok = cTok
transSort Sort_Str = cStr
transSort Sort_Strs = cStrs
transSort :: Sort -> Err String
transSort x = case x of
_ -> return $ printTree x
{-
--- no more used 7/1/2006 AR
@@ -703,7 +705,7 @@ transOldGrammar opts name0 x = case x of
resName = identPI $ maybe ("Res" ++ lang) id $ getOptVal opts useResName
cncName = identPI $ maybe lang id $ getOptVal opts useCncName
identPI s = PIdent ((0,0),s)
identPI s = PIdent ((0,0),BS.pack s)
(beg,rest) = span (/='.') name
(topic,lang) = case rest of -- to avoid overwriting old files
@@ -725,8 +727,8 @@ transInclude x = case x of
FDot filename -> '.' : trans filename
FMinus filename -> '-' : trans filename
FAddId (PIdent (_, s)) filename -> modif s ++ trans filename
modif s = let s' = init s ++ [toLower (last s)] in
if elem s' newReservedWords then s' else s
modif s = let s' = BS.snoc (BS.init s) (toLower (BS.last s)) in
BS.unpack (if elem (BS.unpack s') newReservedWords then s' else s)
--- unsafe hack ; cf. GetGrammar.oldLexer
@@ -740,16 +742,16 @@ termInPattern t = M.mkAbs xx $ G.R [(s, (Nothing, toP body))] where
toP t = case t of
G.Vr x -> G.P t s
_ -> M.composSafeOp toP t
s = G.LIdent "s"
s = G.LIdent (BS.pack "s")
(xx,body) = abss [] t
abss xs t = case t of
G.Abs x b -> abss (x:xs) b
_ -> (reverse xs,t)
mkListId,mkConsId,mkBaseId :: Ident -> Ident
mkListId = prefixId "List"
mkConsId = prefixId "Cons"
mkBaseId = prefixId "Base"
mkListId = prefixId (BS.pack "List")
mkConsId = prefixId (BS.pack "Cons")
mkBaseId = prefixId (BS.pack "Base")
prefixId :: String -> Ident -> Ident
prefixId pref id = IC (pref ++ prIdent id)
prefixId :: BS.ByteString -> Ident -> Ident
prefixId pref id = identC (BS.append pref (ident2bs id))

116
src-3.0/GF/Source/TestGF.hs
View File

@@ -1,58 +1,58 @@
-- automatically generated by BNF Converter
module Main where
import IO ( stdin, hGetContents )
import System ( getArgs, getProgName )
import GF.Source.LexGF
import GF.Source.ParGF
import GF.Source.SkelGF
import GF.Source.PrintGF
import GF.Source.AbsGF
import GF.Source.ErrM
type ParseFun a = [Token] -> Err a
myLLexer = myLexer
type Verbosity = Int
putStrV :: Verbosity -> String -> IO ()
putStrV v s = if v > 1 then putStrLn s else return ()
runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
runFile v p f = putStrLn f >> readFile f >>= run v p
run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
run v p s = let ts = myLLexer s in case p ts of
Bad s -> do putStrLn "\nParse Failed...\n"
putStrV v "Tokens:"
putStrV v $ show ts
putStrLn s
Ok tree -> do putStrLn "\nParse Successful!"
showTree v tree
showTree :: (Show a, Print a) => Int -> a -> IO ()
showTree v tree
= do
putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
main :: IO ()
main = do args <- getArgs
case args of
[] -> hGetContents stdin >>= run 2 pGrammar
"-s":fs -> mapM_ (runFile 0 pGrammar) fs
fs -> mapM_ (runFile 2 pGrammar) fs
-- automatically generated by BNF Converter
module Main where
import IO ( stdin, hGetContents )
import System ( getArgs, getProgName )
import GF.Source.LexGF
import GF.Source.ParGF
import GF.Source.SkelGF
import GF.Source.PrintGF
import GF.Source.AbsGF
import GF.Source.ErrM
type ParseFun a = [Token] -> Err a
myLLexer = myLexer
type Verbosity = Int
putStrV :: Verbosity -> String -> IO ()
putStrV v s = if v > 1 then putStrLn s else return ()
runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
runFile v p f = putStrLn f >> readFile f >>= run v p
run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
run v p s = let ts = myLLexer s in case p ts of
Bad s -> do putStrLn "\nParse Failed...\n"
putStrV v "Tokens:"
putStrV v $ show ts
putStrLn s
Ok tree -> do putStrLn "\nParse Successful!"
showTree v tree
showTree :: (Show a, Print a) => Int -> a -> IO ()
showTree v tree
= do
putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
main :: IO ()
main = do args <- getArgs
case args of
[] -> hGetContents stdin >>= run 2 pGrammar
"-s":fs -> mapM_ (runFile 0 pGrammar) fs
fs -> mapM_ (runFile 2 pGrammar) fs

3
src-3.0/GF/UseGrammar/Editing.hs
View File

@@ -20,7 +20,6 @@ import qualified GF.Canon.GFC as GFC
import GF.Grammar.TypeCheck
import GF.Grammar.LookAbs
import GF.Grammar.AbsCompute
import GF.Grammar.Macros (errorCat)
import GF.Data.Operations
import GF.Data.Zipper
@@ -51,7 +50,7 @@ actVal :: State -> Val
actVal = valNode . nodeTree . actTree
actCat :: State -> Cat
actCat = errVal errorCat . val2cat . actVal ---- undef
actCat = errVal (cMeta,cMeta) . val2cat . actVal ---- undef
actAtom :: State -> Atom
actAtom = atomTree . actTree

4
src-3.0/Makefile
View File

@@ -4,7 +4,7 @@ include config.mk
GHMAKE=$(GHC) --make
GHCXMAKE=ghcxmake
GHCFLAGS+= -fglasgow-exts
GHCOPTFLAGS=-O2
GHCOPTFLAGS=-O2 -prof
GHCFUDFLAG=
JAVAFLAGS=-target 1.4 -source 1.4
GFEDITOR=JavaGUI2
@@ -207,7 +207,7 @@ gfc: gf3
gfi: gf3
gf3:
$(GHMAKE) $(GHCOPTFLAGS) $(GHCFLAGS) -o gf3 GF/Devel/GF.hs
$(GHMAKE) $(GHCOPTFLAGS) -o gf3 GF/Devel/GF.hs
strip $(GF3_EXE)
mv $(GF3_EXE) ../bin/

8
src-3.0/exper/Optimize.hs
View File

@@ -114,9 +114,9 @@ evalCncInfo opts gr cnc abs (c,info) = errIn ("optimizing" +++ prt c) $ case inf
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
@@ -222,7 +222,7 @@ 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)
RecType lts -> mapPairsM mkDefField lts >>= (return . Abs varStr . R . mkAssign)
_ -> prtBad "linearization type must be a record type, not" typ
where
mkDefField typ = case unComputed typ of
@@ -230,7 +230,7 @@ mkLinDefault gr typ = do
t' <- mkDefField t
let T _ cs = mkWildCases t'
return $ T (TWild p) cs
Sort "Str" -> return $ Vr strVar
Sort "Str" -> return $ Vr varStr
QC q p -> lookupFirstTag gr q p
RecType r -> do
let (ls,ts) = unzip r