diff --git a/src/GF/Devel/Grammar/Macros.hs b/src/GF/Devel/Grammar/Macros.hs index 4848a5e1a..12fa1e747 100644 --- a/src/GF/Devel/Grammar/Macros.hs +++ b/src/GF/Devel/Grammar/Macros.hs @@ -45,6 +45,9 @@ mkDecl typ = (wildIdent, typ) typeType :: Type typeType = Sort "Type" +meta0 :: Term +meta0 = Meta 0 + ident2label :: Ident -> Label ident2label c = LIdent (prIdent c) @@ -155,6 +158,10 @@ composOp co trm = case trm of aa' <- mapM (pairM co) aa return (Alts (t',aa')) FV ts -> mapM co ts >>= return . FV + Overload tts -> do + tts' <- mapM (pairM co) tts + return $ Overload tts' + _ -> return trm -- covers K, Vr, Cn, Sort --- just aux to composOp? diff --git a/src/GF/Devel/Grammar/MkJudgements.hs b/src/GF/Devel/Grammar/MkJudgements.hs index 795bf6f67..833d2f695 100644 --- a/src/GF/Devel/Grammar/MkJudgements.hs +++ b/src/GF/Devel/Grammar/MkJudgements.hs @@ -47,17 +47,20 @@ resOperDef tr = addJDef tr (emptyJudgement JOper) resOper :: Type -> Term -> Judgement resOper ty tr = addJDef tr (resOperType ty) --- param m.p = c g is encoded as p : (ci : gi -> EData) -> Type --- we use EData instead of m.p to make circularity check easier -resParam :: Ident -> Ident -> [(Ident,Context)] -> Judgement -resParam m p cos = addJType constrs (emptyJudgement JParam) where +resOverload :: [(Type,Term)] -> Judgement +resOverload tts = resOperDef (Overload tts) + +-- param p = ci gi is encoded as p : ((ci : gi) -> EData) -> Type +-- we use EData instead of p to make circularity check easier +resParam :: [(Ident,Context)] -> Judgement +resParam cos = addJType constrs (emptyJudgement JParam) where constrs = mkProd [(c,mkProd co EData) | (c,co) <- cos] typeType -- to enable constructor type lookup: --- create an oper for each constructor m.p = c g, as c : g -> m.p = EData -paramConstructors :: Ident -> Ident -> [(Ident,Context)] -> [(Ident,Judgement)] -paramConstructors m p cs = - [(c,resOper (mkProd co (QC m p)) EData) | (c,co) <- cs] +-- create an oper for each constructor p = c g, as c : g -> p = EData +paramConstructors :: Ident -> [(Ident,Context)] -> [(Ident,Judgement)] +paramConstructors p cs = + [(c,resOper (mkProd co (Con p)) EData) | (c,co) <- cs] -- unifying contents of judgements diff --git a/src/GF/Devel/Grammar/Modules.hs b/src/GF/Devel/Grammar/Modules.hs index 774cc6387..0d3d96114 100644 --- a/src/GF/Devel/Grammar/Modules.hs +++ b/src/GF/Devel/Grammar/Modules.hs @@ -27,13 +27,13 @@ data Module = Module { mextends :: [(Ident,MInclude)], mopens :: [(Ident,Ident)], -- used name, original name mflags :: Map Ident String, - mjments :: Map Ident (Either Judgement Ident) -- def or indirection + mjments :: Map Ident (Either Judgement Indirection) -- def or indirection } emptyModule :: Ident -> Module emptyModule m = Module MTGrammar [] [] [] [] empty empty -listJudgements :: Module -> [(Ident,Either Judgement Ident)] +listJudgements :: Module -> [(Ident,Either Judgement Indirection)] listJudgements = assocs . mjments data ModuleType = @@ -46,4 +46,5 @@ data MInclude = | MIExcept [Ident] | MIOnly [Ident] +type Indirection = (Ident,Bool) -- module of origin, whether canonical diff --git a/src/GF/Devel/Grammar/SourceToGF.hs b/src/GF/Devel/Grammar/SourceToGF.hs index d40026851..cefc1192c 100644 --- a/src/GF/Devel/Grammar/SourceToGF.hs +++ b/src/GF/Devel/Grammar/SourceToGF.hs @@ -248,13 +248,7 @@ transResDef :: TopDef -> Err (Either [(Ident,Judgement)] [(Ident,String)]) transResDef x = case x of DefPar pardefs -> do pardefs' <- mapM transParDef pardefs - returnl $ [] - ---- [(p, resParam (if null pars - ---- then nope -- abstract param type - ---- else (yes (pars,Nothing)))) - ---- | (p,pars) <- pardefs'] - ---- ++ [(f, G.ResValue (yes (M.mkProd co (G.Con p),Nothing))) | - ---- (p,pars) <- pardefs', (f,co) <- pars] + returnl $ concatMap mkParamDefs pardefs' DefOper defs -> do defs' <- liftM concat $ mapM getDefs defs @@ -267,19 +261,21 @@ transResDef x = case x of DefFlag defs -> liftM (Right . concat) $ mapM transFlagDef defs _ -> Bad $ "illegal definition form in resource" +++ printTree x where - mkOverload (c,j) = case j of -{- ---- - G.ResOper _ (Yes (G.App keyw (G.R fs@(_:_:_)))) | - isOverloading keyw c fs -> - [(c,G.ResOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])] + + mkParamDefs (p,pars) = + if null pars + then [(p,addJType M.meta0 (emptyJudgement JParam))] -- in an interface + else (p,resParam pars) : paramConstructors p pars + + mkOverload (c,j) = case (jtype j, jdef j) of + (_,G.App keyw (G.R fs@(_:_:_))) | isOverloading keyw c fs -> + [(c,resOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])] -- to enable separare type signature --- not type-checked - G.ResOper (Yes (G.App keyw (G.RecType fs@(_:_:_)))) _ | - isOverloading keyw c fs -> [] --} + (G.App keyw (G.RecType fs@(_:_:_)),_) | isOverloading keyw c fs -> [] _ -> [(c,j)] - isOverloading keyw c fs = - printTree keyw == "overload" && -- overload is a "soft keyword" + isOverloading (G.Vr keyw) c fs = + prIdent keyw == "overload" && -- overload is a "soft keyword" False ---- all (== GP.prt c) (map (GP.prt . fst) fs) transParDef :: ParDef -> Err (Ident, [(Ident,G.Context)]) diff --git a/src/GF/Devel/Grammar/Terms.hs b/src/GF/Devel/Grammar/Terms.hs index bfbdff7d0..d57e7c160 100644 --- a/src/GF/Devel/Grammar/Terms.hs +++ b/src/GF/Devel/Grammar/Terms.hs @@ -54,6 +54,8 @@ data Term = | Alts (Term, [(Term, Term)]) -- ^ prefix-dependent: @pre {t ; s\/c ; ...}@ + | Overload [(Type,Term)] + deriving (Read, Show, Eq, Ord) data Patt = diff --git a/src/GF/Devel/TestGF3.hs b/src/GF/Devel/TestGF3.hs new file mode 100644 index 000000000..3f3b9f358 --- /dev/null +++ b/src/GF/Devel/TestGF3.hs @@ -0,0 +1,29 @@ +module Main where + +import GF.Devel.Grammar.LexGF +import GF.Devel.Grammar.ParGF +---- import GF.Devel.Grammar.PrintGF +import GF.Devel.Grammar.AbsGF + +import GF.Devel.Grammar.SourceToGF + +import qualified GF.Devel.Grammar.ErrM as GErr ---- +import GF.Data.Operations + +import System (getArgs) + +main = do + f:_ <- getArgs + s <- readFile f + let tt = myLexer s + case pGrammar tt of + GErr.Bad s -> putStrLn s + GErr.Ok g -> compile g + +compile g = do + let eg = transGrammar g + case eg of + Ok _ -> putStrLn "OK" + Bad s -> putStrLn s + return () + diff --git a/src/Makefile b/src/Makefile index bdb94401c..4f342324d 100644 --- a/src/Makefile +++ b/src/Makefile @@ -34,6 +34,7 @@ GF_EXE=gf$(EXEEXT) GF_EXE_TMP=gf-bin$(EXEEXT) GF_DOC_EXE=gfdoc$(EXEEXT) GF3_EXE=gf3$(EXEEXT) +TESTGF3_EXE=testgf3$(EXEEXT) ifeq ("$(READLINE)","readline") @@ -206,6 +207,11 @@ gf3: strip $(GF3_EXE) mv $(GF3_EXE) ../bin/ +testgf3: + $(GHMAKE) $(GHCOPTFLAGS) -o testgf3 GF/Devel/TestGF3.hs + strip $(TESTGF3_EXE) + mv $(TESTGF3_EXE) ../bin/ + gfcc2c: $(MAKE) -C tools/c $(MAKE) -C ../lib/c