From d9521d2f4c8fa0eb515beefbe07bab4d16b6a543 Mon Sep 17 00:00:00 2001 From: aarne Date: Fri, 7 Dec 2007 20:47:58 +0000 Subject: restructured some of the new GF format; modules now in place up to gfo generation --- src/GF/Devel/CheckM.hs | 3 +- src/GF/Devel/Compile/CheckGrammar.hs | 20 +- src/GF/Devel/Compile/Compile.hs | 5 +- src/GF/Devel/Compile/Extend.hs | 28 +- src/GF/Devel/Compile/Factorize.hs | 62 ++-- src/GF/Devel/Compile/GF.cf | 319 ++++++++++++++++ src/GF/Devel/Compile/GetGrammar.hs | 11 +- src/GF/Devel/Compile/Optimize.hs | 5 +- src/GF/Devel/Compile/Refresh.hs | 4 +- src/GF/Devel/Compile/Rename.hs | 16 +- src/GF/Devel/Compile/SourceToGF.hs | 667 +++++++++++++++++++++++++++++++++ src/GF/Devel/Grammar/AppPredefined.hs | 3 +- src/GF/Devel/Grammar/Compute.hs | 4 +- src/GF/Devel/Grammar/Construct.hs | 216 +++++++++++ src/GF/Devel/Grammar/GF.cf | 319 ---------------- src/GF/Devel/Grammar/GFtoSource.hs | 10 +- src/GF/Devel/Grammar/Grammar.hs | 161 ++++++++ src/GF/Devel/Grammar/Judgements.hs | 21 -- src/GF/Devel/Grammar/Lookup.hs | 17 +- src/GF/Devel/Grammar/Macros.hs | 58 +-- src/GF/Devel/Grammar/MkJudgements.hs | 93 ----- src/GF/Devel/Grammar/Modules.hs | 96 ----- src/GF/Devel/Grammar/PatternMatch.hs | 2 +- src/GF/Devel/Grammar/PrGF.hs | 10 +- src/GF/Devel/Grammar/SourceToGF.hs | 670 ---------------------------------- src/GF/Devel/Grammar/Terms.hs | 118 ------ 26 files changed, 1457 insertions(+), 1481 deletions(-) create mode 100644 src/GF/Devel/Compile/GF.cf create mode 100644 src/GF/Devel/Compile/SourceToGF.hs create mode 100644 src/GF/Devel/Grammar/Construct.hs delete mode 100644 src/GF/Devel/Grammar/GF.cf create mode 100644 src/GF/Devel/Grammar/Grammar.hs delete mode 100644 src/GF/Devel/Grammar/Judgements.hs delete mode 100644 src/GF/Devel/Grammar/MkJudgements.hs delete mode 100644 src/GF/Devel/Grammar/Modules.hs delete mode 100644 src/GF/Devel/Grammar/SourceToGF.hs delete mode 100644 src/GF/Devel/Grammar/Terms.hs (limited to 'src/GF') diff --git a/src/GF/Devel/CheckM.hs b/src/GF/Devel/CheckM.hs index 7f85b0570..d26dbc07c 100644 --- a/src/GF/Devel/CheckM.hs +++ b/src/GF/Devel/CheckM.hs @@ -20,8 +20,7 @@ module GF.Devel.CheckM (Check, ) where import GF.Data.Operations -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar import GF.Infra.Ident import GF.Devel.Grammar.PrGF diff --git a/src/GF/Devel/Compile/CheckGrammar.hs b/src/GF/Devel/Compile/CheckGrammar.hs index d2f7af8fd..55f499d38 100644 --- a/src/GF/Devel/Compile/CheckGrammar.hs +++ b/src/GF/Devel/Compile/CheckGrammar.hs @@ -29,10 +29,8 @@ module GF.Devel.Compile.CheckGrammar ( topoSortOpers ) where -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.Terms -import GF.Devel.Grammar.MkJudgements +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.Macros import GF.Devel.Grammar.PrGF import GF.Devel.Grammar.Lookup @@ -187,19 +185,19 @@ checkCompleteGrammar abs cnc = do js' <- foldM checkOne js fs return $ cnc {mjments = js'} where - checkOne js i@(c, Left ju) = case jform ju of + checkOne js i@(c, ju) = case jform ju of JFun -> case Map.lookup c js of - Just (Left j) | jform j == JLin -> return js + Just j | jform j == JLin -> return js _ -> do checkWarn $ "WARNING: no linearization of" +++ prt c return js JCat -> case Map.lookup c js of - Just (Left j) | jform ju == JLincat -> return js + Just j | jform ju == JLincat -> return js _ -> do ---- TODO: other things to check here checkWarn $ "Warning: no linearization type for" +++ prt c ++ ", inserting default {s : Str}" - return $ Map.insert c (Left (cncCat defLinType)) js + return $ Map.insert c (cncCat defLinType) js _ -> return js checkResInfo :: GF -> Ident -> Ident -> Judgement -> Check Judgement @@ -1055,12 +1053,12 @@ linTypeOfType cnc m typ = do -- | dependency check, detecting circularities and returning topo-sorted list -allOperDependencies :: Ident -> Map.Map Ident JEntry -> [(Ident,[Ident])] +allOperDependencies :: Ident -> Map.Map Ident Judgement -> [(Ident,[Ident])] allOperDependencies m = allDependencies (==m) -allDependencies :: (Ident -> Bool) -> Map.Map Ident JEntry -> [(Ident,[Ident])] +allDependencies :: (Ident -> Bool) -> Map.Map Ident Judgement -> [(Ident,[Ident])] allDependencies ism b = - [(f, nub (concatMap opersIn (pts i))) | (f,Left i) <- Map.assocs b] + [(f, nub (concatMap opersIn (pts i))) | (f,i) <- Map.assocs b] where opersIn t = case t of Q n c | ism n -> [c] diff --git a/src/GF/Devel/Compile/Compile.hs b/src/GF/Devel/Compile/Compile.hs index 729a40df7..df3ea079e 100644 --- a/src/GF/Devel/Compile/Compile.hs +++ b/src/GF/Devel/Compile/Compile.hs @@ -9,9 +9,8 @@ import GF.Devel.Compile.Refresh import GF.Devel.Compile.Optimize import GF.Devel.Compile.Factorize -import GF.Devel.Grammar.Terms -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Judgements +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Infra.Ident import GF.Devel.Grammar.PrGF ----import GF.Devel.Grammar.Lookup diff --git a/src/GF/Devel/Compile/Extend.hs b/src/GF/Devel/Compile/Extend.hs index 8dbbe0382..2f1aae65b 100644 --- a/src/GF/Devel/Compile/Extend.hs +++ b/src/GF/Devel/Compile/Extend.hs @@ -20,9 +20,8 @@ module GF.Devel.Compile.Extend ( extendModule ) where -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.MkJudgements +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.PrGF import GF.Devel.Grammar.Lookup import GF.Devel.Grammar.Macros @@ -71,28 +70,23 @@ extendModule gf nmo0 = do -- and the process is interrupted if unification fails. -- If the extended module is incomplete, its judgements are just copied. extendMod :: Bool -> Ident -> (Ident -> Bool) -> Ident -> - MapJudgement -> MapJudgement -> Err MapJudgement + Map Ident Judgement -> Map Ident Judgement -> + Err (Map Ident Judgement) extendMod isCompl name cond base old new = foldM try new $ assocs old where try t i@(c,_) | not (cond c) = return t try t i@(c,_) = errIn ("constant" +++ prt c) $ tryInsert (extendAnyInfo isCompl name base) indirIf t i indirIf = if isCompl then indirInfo name else id -indirInfo :: Ident -> JEntry -> JEntry -indirInfo n info = Right $ case info of - Right (k,b) -> (k,b) -- original link is passed - Left j -> (n,isConstructor j) +indirInfo :: Ident -> Judgement -> Judgement +indirInfo n ju = case jform ju of + JLink -> ju -- original link is passed + _ -> linkInherited (isConstructor ju) n -extendAnyInfo :: Bool -> Ident -> Ident -> JEntry -> JEntry -> Err JEntry +extendAnyInfo :: Bool -> Ident -> Ident -> Judgement -> Judgement -> Err Judgement extendAnyInfo isc n o i j = - errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $ case (i,j) of - (Left j1,Left j2) -> liftM Left $ unifyJudgement j1 j2 - (Right (m1,b1), Right (m2,b2)) -> do - testErr (b1 == b2) "inconsistent indirection status" - testErr (m1 == m2) $ - "different sources of inheritance:" +++ show m1 +++ show m2 - return i - _ -> Bad $ "cannot unify information in" ++++ prJEntry i ++++ prJEntry j + errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $ + unifyJudgement i j tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) -> Map a b -> (a,b) -> Err (Map a b) diff --git a/src/GF/Devel/Compile/Factorize.hs b/src/GF/Devel/Compile/Factorize.hs index 4f732181e..cb9a684ff 100644 --- a/src/GF/Devel/Compile/Factorize.hs +++ b/src/GF/Devel/Compile/Factorize.hs @@ -24,10 +24,8 @@ module GF.Devel.Compile.Factorize ( shareModule ) where -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.Terms -import GF.Devel.Grammar.MkJudgements +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.PrGF (prt) import qualified GF.Devel.Grammar.Macros as C @@ -53,10 +51,11 @@ unshareModule :: GF -> SourceModule -> SourceModule unshareModule gr = processModule (const (unoptim gr)) processModule :: (Ident -> Term -> Term) -> SourceModule -> SourceModule -processModule opt (i,m) = (i, C.judgementOpModule (shareInfo (opt i)) m) +processModule opt (i,mo) = + (i, mo {mjments = Map.map (shareInfo (opt i)) (mjments mo)}) -shareInfo :: (Term -> Term) -> Judgement -> Err Judgement -shareInfo opt ju = return $ ju {jdef = opt (jdef ju)} +shareInfo :: (Term -> Term) -> Judgement -> Judgement +shareInfo opt ju = ju {jdef = opt (jdef ju)} -- the function putting together optimizations optim :: Ident -> Term -> Term @@ -169,34 +168,25 @@ cse is possible in the grammar. It is used by the flag pg -printer=subs. -} subexpModule :: SourceModule -> SourceModule -subexpModule (mo,m) = errVal (mo,m) $ case m of - M.ModMod (M.Module mt st fs me ops js) -> do - (tree,_) <- appSTM (getSubtermsMod mo (tree2list js)) (Map.empty,0) - js2 <- liftM buildTree $ addSubexpConsts mo tree $ tree2list js - return (mo,M.ModMod (M.Module mt st fs me ops js2)) - _ -> return (mo,m) +subexpModule (m,mo) = errVal (m,mo) $ case mtype mo of + MTAbstract -> return (m,mo) + _ -> do + let js = listJudgements mo + (tree,_) <- appSTM (getSubtermsMod m js) (Map.empty,0) + js2 <- addSubexpConsts m tree js + return (m, mo{mjments = Map.fromList js2}) unsubexpModule :: SourceModule -> SourceModule -unsubexpModule mo@(i,m) = case m of - M.ModMod (M.Module mt st fs me ops js) | hasSub ljs -> - (i, M.ModMod (M.Module mt st fs me ops - (rebuild (map unparInfo ljs)))) - where ljs = tree2list js - _ -> (i,m) +unsubexpModule (m,mo) = (m, mo{mjments = rebuild (mjments mo)}) where - -- perform this iff the module has opers - hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs] - unparInfo (c,info) = case info of - CncFun xs (Yes t) m -> [(c, CncFun xs (Yes (unparTerm t)) m)] - ResOper (Yes (EInt 8)) _ -> [] -- subexp-generated opers - ResOper pty (Yes t) -> [(c, ResOper pty (Yes (unparTerm t)))] - _ -> [(c,info)] + unparInfo (c, ju) = case jtype ju of + EInt 8 -> [] -- subexp-generated opers + _ -> [(c, ju {jdef = unparTerm (jdef ju)})] unparTerm t = case t of - Q m c@(IC ('A':'\'':'\'':_)) -> --- name convention of subexp opers - errVal t $ liftM unparTerm $ lookupResDef gr m c + Q _ c@(IC ('_':'A':_)) -> --- name convention of subexp opers + maybe t (unparTerm . jdef) $ Map.lookup c (mjments mo) _ -> C.composSafeOp unparTerm t - gr = M.MGrammar [mo] - rebuild = buildTree . concat + rebuild = Map.fromList . concat . map unparInfo . Map.assocs -- implementation @@ -204,20 +194,20 @@ type TermList = Map Term (Int,Int) -- number of occs, id type TermM a = STM (TermList,Int) a addSubexpConsts :: - Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> Err [(Ident,Info)] + Ident -> Map Term (Int,Int) -> [(Ident,Judgement)] -> Err [(Ident,Judgement)] addSubexpConsts mo tree lins = do let opers = [oper id trm | (trm,(_,id)) <- list] mapM mkOne $ opers ++ lins where - mkOne (f,def) = (f,def {jdef = recomp f (jdef def)}) + mkOne (f, def) = return (f, def {jdef = recomp f (jdef def)}) recomp f t = case Map.lookup t tree of - Just (_,id) | ident id /= f -> return $ Q mo (ident id) - _ -> C.composOp (recomp f) t + Just (_,id) | ident id /= f -> Q mo (ident id) + _ -> C.composSafeOp (recomp f) t list = Map.toList tree - oper id trm = (ident id, resOper (EInt 8) (Yes trm)) + oper id trm = (ident id, resOper (EInt 8) trm) --- impossible type encoding generated opers getSubtermsMod :: Ident -> [(Ident,Judgement)] -> TermM (Map Term (Int,Int)) @@ -226,7 +216,7 @@ getSubtermsMod mo js = do (tree0,_) <- readSTM return $ Map.filter (\ (nu,_) -> nu > 1) tree0 where - getInfo get fi@(f,i) = do + getInfo get fi@(_,i) = do get (jdef i) return $ fi diff --git a/src/GF/Devel/Compile/GF.cf b/src/GF/Devel/Compile/GF.cf new file mode 100644 index 000000000..6fc9307b2 --- /dev/null +++ b/src/GF/Devel/Compile/GF.cf @@ -0,0 +1,319 @@ +-- AR 2/5/2003, 14-16 o'clock, Torino + +-- 17/6/2007: marked with suffix --% those lines that are obsolete and +-- should not be included in documentation + +entrypoints Grammar, ModDef, + OldGrammar, --% + Exp ; -- let's see if more are needed + +comment "--" ; +comment "{-" "-}" ; + + +-- identifiers + +position token PIdent (letter | '_') (letter | digit | '_' | '\'')* ; + +-- the top-level grammar + +Gr. Grammar ::= [ModDef] ; + +-- semicolon after module is permitted but not obligatory + +terminator ModDef "" ; +_. ModDef ::= ModDef ";" ; + +-- the individual modules + +MModule. ModDef ::= ComplMod ModType "=" ModBody ; + +MAbstract. ModType ::= "abstract" PIdent ; +MResource. ModType ::= "resource" PIdent ; +MGrammar. ModType ::= "grammar" PIdent ; +MInterface. ModType ::= "interface" PIdent ; +MConcrete. ModType ::= "concrete" PIdent "of" PIdent ; +MInstance. ModType ::= "instance" PIdent "of" PIdent ; + +MBody. ModBody ::= Extend Opens "{" [TopDef] "}" ; +MNoBody. ModBody ::= [Included] ; +MWith. ModBody ::= Included "with" [Open] ; +MWithBody. ModBody ::= Included "with" [Open] "**" Opens "{" [TopDef] "}" ; +MWithE. ModBody ::= [Included] "**" Included "with" [Open] ; +MWithEBody. ModBody ::= [Included] "**" Included "with" [Open] "**" Opens "{" [TopDef] "}" ; + +MReuse. ModBody ::= "reuse" PIdent ; --% +MUnion. ModBody ::= "union" [Included] ;--% + +separator TopDef "" ; + +Ext. Extend ::= [Included] "**" ; +NoExt. Extend ::= ; + +separator Open "," ; +NoOpens. Opens ::= ; +OpenIn. Opens ::= "open" [Open] "in" ; + +OName. Open ::= PIdent ; +-- OQualQO. Open ::= "(" PIdent ")" ; --% +OQual. Open ::= "(" PIdent "=" PIdent ")" ; + +CMCompl. ComplMod ::= ; +CMIncompl. ComplMod ::= "incomplete" ; + +separator Included "," ; + +IAll. Included ::= PIdent ; +ISome. Included ::= PIdent "[" [PIdent] "]" ; +IMinus. Included ::= PIdent "-" "[" [PIdent] "]" ; + +-- top-level definitions + +DefCat. TopDef ::= "cat" [CatDef] ; +DefFun. TopDef ::= "fun" [FunDef] ; +DefFunData.TopDef ::= "data" [FunDef] ; +DefDef. TopDef ::= "def" [Def] ; +DefData. TopDef ::= "data" [DataDef] ; + +DefPar. TopDef ::= "param" [ParDef] ; +DefOper. TopDef ::= "oper" [Def] ; + +DefLincat. TopDef ::= "lincat" [Def] ; +DefLindef. TopDef ::= "lindef" [Def] ; +DefLin. TopDef ::= "lin" [Def] ; + +DefPrintCat. TopDef ::= "printname" "cat" [Def] ; +DefPrintFun. TopDef ::= "printname" "fun" [Def] ; +DefFlag. TopDef ::= "flags" [Def] ; + +-- definitions after most keywords + +DDecl. Def ::= [Name] ":" Exp ; +DDef. Def ::= [Name] "=" Exp ; +DPatt. Def ::= Name [Patt] "=" Exp ; -- non-empty pattern list +DFull. Def ::= [Name] ":" Exp "=" Exp ; + +FDecl. FunDef ::= [Name] ":" Exp ; + +SimpleCatDef. CatDef ::= PIdent [DDecl] ; +ListCatDef. CatDef ::= "[" PIdent [DDecl] "]" ; +ListSizeCatDef. CatDef ::= "[" PIdent [DDecl] "]" "{" Integer "}" ; + +DataDef. DataDef ::= Name "=" [DataConstr] ; +DataId. DataConstr ::= PIdent ; +DataQId. DataConstr ::= PIdent "." PIdent ; +separator DataConstr "|" ; + +ParDefDir. ParDef ::= PIdent "=" [ParConstr] ; +ParDefAbs. ParDef ::= PIdent ; + +ParConstr. ParConstr ::= PIdent [DDecl] ; + +terminator nonempty Def ";" ; +terminator nonempty FunDef ";" ; +terminator nonempty CatDef ";" ; +terminator nonempty DataDef ";" ; +terminator nonempty ParDef ";" ; + +separator ParConstr "|" ; + +separator nonempty PIdent "," ; + +-- names of categories and functions in definition LHS + +PIdentName. Name ::= PIdent ; +ListName. Name ::= "[" PIdent "]" ; + +separator nonempty Name "," ; + +-- definitions in records and $let$ expressions + +LDDecl. LocDef ::= [PIdent] ":" Exp ; +LDDef. LocDef ::= [PIdent] "=" Exp ; +LDFull. LocDef ::= [PIdent] ":" Exp "=" Exp ; + +separator LocDef ";" ; + +-- terms and types + +EPIdent. Exp6 ::= PIdent ; +EConstr. Exp6 ::= "{" PIdent "}" ;--% +ECons. Exp6 ::= "%" PIdent "%" ;--% +ESort. Exp6 ::= Sort ; +EString. Exp6 ::= String ; +EInt. Exp6 ::= Integer ; +EFloat. Exp6 ::= Double ; +EMeta. Exp6 ::= "?" ; +EEmpty. Exp6 ::= "[" "]" ; +EData. Exp6 ::= "data" ; +EList. Exp6 ::= "[" PIdent Exps "]" ; +EStrings. Exp6 ::= "[" String "]" ; +ERecord. Exp6 ::= "{" [LocDef] "}" ; -- ! +ETuple. Exp6 ::= "<" [TupleComp] ">" ; --- needed for separator "," +EIndir. Exp6 ::= "(" "in" PIdent ")" ; -- indirection, used in judgements --% +ETyped. Exp6 ::= "<" Exp ":" Exp ">" ; -- typing, used for annotations + +EProj. Exp5 ::= Exp5 "." Label ; +EQConstr. Exp5 ::= "{" PIdent "." PIdent "}" ; -- qualified constructor --% +EQCons. Exp5 ::= "%" PIdent "." PIdent ; -- qualified constant --% + +EApp. Exp4 ::= Exp4 Exp5 ; +ETable. Exp4 ::= "table" "{" [Case] "}" ; +ETTable. Exp4 ::= "table" Exp6 "{" [Case] "}" ; +EVTable. Exp4 ::= "table" Exp6 "[" [Exp] "]" ; +ECase. Exp4 ::= "case" Exp "of" "{" [Case] "}" ; +EVariants. Exp4 ::= "variants" "{" [Exp] "}" ; +EPre. Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ; +EStrs. Exp4 ::= "strs" "{" [Exp] "}" ; + +ESelect. Exp3 ::= Exp3 "!" Exp4 ; +ETupTyp. Exp3 ::= Exp3 "*" Exp4 ; +EExtend. Exp3 ::= Exp3 "**" Exp4 ; + +EGlue. Exp1 ::= Exp2 "+" Exp1 ; + +EConcat. Exp ::= Exp1 "++" Exp ; + +EAbstr. Exp ::= "\\" [Bind] "->" Exp ; +ECTable. Exp ::= "\\""\\" [Bind] "=>" Exp ; +EProd. Exp ::= Decl "->" Exp ; +ETType. Exp ::= Exp3 "=>" Exp ; -- these are thus right associative +ELet. Exp ::= "let" "{" [LocDef] "}" "in" Exp ; +ELetb. Exp ::= "let" [LocDef] "in" Exp ; +EWhere. Exp ::= Exp3 "where" "{" [LocDef] "}" ; +EEqs. Exp ::= "fn" "{" [Equation] "}" ; --% + +EExample. Exp ::= "in" Exp5 String ; + +coercions Exp 6 ; + +separator Exp ";" ; -- in variants + +-- list of arguments to category +NilExp. Exps ::= ; +ConsExp. Exps ::= Exp6 Exps ; -- Exp6 to force parantheses + +-- patterns + +PW. Patt2 ::= "_" ; +PV. Patt2 ::= PIdent ; +PCon. Patt2 ::= "{" PIdent "}" ; --% +PQ. Patt2 ::= PIdent "." PIdent ; +PInt. Patt2 ::= Integer ; +PFloat. Patt2 ::= Double ; +PStr. Patt2 ::= String ; +PR. Patt2 ::= "{" [PattAss] "}" ; +PTup. Patt2 ::= "<" [PattTupleComp] ">" ; +PC. Patt1 ::= PIdent [Patt] ; +PQC. Patt1 ::= PIdent "." PIdent [Patt] ; +PDisj. Patt ::= Patt "|" Patt1 ; +PSeq. Patt ::= Patt "+" Patt1 ; +PRep. Patt1 ::= Patt2 "*" ; +PAs. Patt1 ::= PIdent "@" Patt2 ; +PNeg. Patt1 ::= "-" Patt2 ; + +coercions Patt 2 ; + +PA. PattAss ::= [PIdent] "=" Patt ; + +-- labels + +LPIdent. Label ::= PIdent ; +LVar. Label ::= "$" Integer ; + +-- basic types + +rules Sort ::= + "Type" + | "PType" + | "Tok" --% + | "Str" + | "Strs" ; + +separator PattAss ";" ; + +-- this is explicit to force higher precedence level on rhs +(:[]). [Patt] ::= Patt2 ; +(:). [Patt] ::= Patt2 [Patt] ; + + +-- binds in lambdas and lin rules + +BPIdent. Bind ::= PIdent ; +BWild. Bind ::= "_" ; + +separator Bind "," ; + + +-- declarations in function types + +DDec. Decl ::= "(" [Bind] ":" Exp ")" ; +DExp. Decl ::= Exp4 ; -- can thus be an application + +-- tuple component (term or pattern) + +TComp. TupleComp ::= Exp ; +PTComp. PattTupleComp ::= Patt ; + +separator TupleComp "," ; +separator PattTupleComp "," ; + +-- case branches + +Case. Case ::= Patt "=>" Exp ; + +separator nonempty Case ";" ; + +-- cases in abstract syntax --% + +Equ. Equation ::= [Patt] "->" Exp ; --% + +separator Equation ";" ; --% + +-- prefix alternatives + +Alt. Altern ::= Exp "/" Exp ; + +separator Altern ";" ; + +-- in a context, higher precedence is required than in function types + +DDDec. DDecl ::= "(" [Bind] ":" Exp ")" ; +DDExp. DDecl ::= Exp6 ; -- can thus *not* be an application + +separator DDecl "" ; + + +-------------------------------------- --% + +-- for backward compatibility --% + +OldGr. OldGrammar ::= Include [TopDef] ; --% + +NoIncl. Include ::= ; --% +Incl. Include ::= "include" [FileName] ; --% + +FString. FileName ::= String ; --% + +terminator nonempty FileName ";" ; --% + +FPIdent. FileName ::= PIdent ; --% +FSlash. FileName ::= "/" FileName ; --% +FDot. FileName ::= "." FileName ; --% +FMinus. FileName ::= "-" FileName ; --% +FAddId. FileName ::= PIdent FileName ; --% + +token LString '\'' (char - '\'')* '\'' ; --% +ELString. Exp6 ::= LString ; --% +ELin. Exp4 ::= "Lin" PIdent ; --% + +DefPrintOld. TopDef ::= "printname" [Def] ; --% +DefLintype. TopDef ::= "lintype" [Def] ; --% +DefPattern. TopDef ::= "pattern" [Def] ; --% + +-- deprecated packages are attempted to be interpreted --% +DefPackage. TopDef ::= "package" PIdent "=" "{" [TopDef] "}" ";" ; --% + +-- these two are just ignored after parsing --% +DefVars. TopDef ::= "var" [Def] ; --% +DefTokenizer. TopDef ::= "tokenizer" PIdent ";" ; --% diff --git a/src/GF/Devel/Compile/GetGrammar.hs b/src/GF/Devel/Compile/GetGrammar.hs index 493a35de2..b90bd912c 100644 --- a/src/GF/Devel/Compile/GetGrammar.hs +++ b/src/GF/Devel/Compile/GetGrammar.hs @@ -15,17 +15,18 @@ module GF.Devel.Compile.GetGrammar where import GF.Devel.UseIO -import GF.Devel.Grammar.Modules +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct ----import GF.Devel.PrGrammar -import GF.Devel.Grammar.SourceToGF +import GF.Devel.Compile.SourceToGF ---- import Macros ---- import Rename --- import Custom -import GF.Devel.Grammar.ParGF -import qualified GF.Devel.Grammar.LexGF as L +import GF.Devel.Compile.ParGF +import qualified GF.Devel.Compile.LexGF as L import GF.Data.Operations -import qualified GF.Devel.Grammar.ErrM as E ---- +import qualified GF.Devel.Compile.ErrM as E ---- import GF.Infra.Option ---- import GF.Devel.ReadFiles ---- diff --git a/src/GF/Devel/Compile/Optimize.hs b/src/GF/Devel/Compile/Optimize.hs index 311715b19..9ed2860fd 100644 --- a/src/GF/Devel/Compile/Optimize.hs +++ b/src/GF/Devel/Compile/Optimize.hs @@ -14,9 +14,8 @@ module GF.Devel.Compile.Optimize (optimizeModule) where -import GF.Devel.Grammar.Modules ---import GF.Devel.Grammar.Judgements ---import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.Macros --import GF.Devel.Grammar.PrGF import GF.Devel.Grammar.Compute diff --git a/src/GF/Devel/Compile/Refresh.hs b/src/GF/Devel/Compile/Refresh.hs index 2a7054851..d512ed39f 100644 --- a/src/GF/Devel/Compile/Refresh.hs +++ b/src/GF/Devel/Compile/Refresh.hs @@ -18,8 +18,8 @@ module GF.Devel.Compile.Refresh ( refreshTermN ) where -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.Macros import GF.Infra.Ident diff --git a/src/GF/Devel/Compile/Rename.hs b/src/GF/Devel/Compile/Rename.hs index df2867f08..fe4f8175f 100644 --- a/src/GF/Devel/Compile/Rename.hs +++ b/src/GF/Devel/Compile/Rename.hs @@ -24,9 +24,8 @@ module GF.Devel.Compile.Rename ( renameModule ) where -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.Macros import GF.Devel.Grammar.PrGF import GF.Infra.Ident @@ -61,7 +60,8 @@ renameIdentTerm :: RenameEnv -> Term -> Err Term renameIdentTerm (gf, (name,mo)) trm = case trm of Vr i -> looks i Con i -> looks i - Q m i -> getQualified m >>= look i + Q m i -> getQualified m >>= look i + QC m i -> getQualified m >>= look i _ -> return trm where looks i = do @@ -76,10 +76,10 @@ renameIdentTerm (gf, (name,mo)) trm = case trm of (return t) ---- _ -> fail $ unwords $ "identifier" : prt i : "ambiguous:" : map prt ts look i m = do - entry <- lookupIdent gf m i - return $ case entry of - Left j -> if isConstructor j then QC m i else Q m i - Right (n,b) -> if b then QC n i else Q n i + ju <- lookupIdent gf m i + return $ case jform ju of + JLink -> if isConstructor ju then QC (jlink ju) i else Q (jlink ju) i + _ -> if isConstructor ju then QC m i else Q m i pool = nub $ name : maybe name id (interfaceName mo) : IC "Predef" : diff --git a/src/GF/Devel/Compile/SourceToGF.hs b/src/GF/Devel/Compile/SourceToGF.hs new file mode 100644 index 000000000..103982147 --- /dev/null +++ b/src/GF/Devel/Compile/SourceToGF.hs @@ -0,0 +1,667 @@ +---------------------------------------------------------------------- +-- | +-- Module : SourceToGF +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/10/04 11:05:07 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.28 $ +-- +-- based on the skeleton Haskell module generated by the BNF converter +----------------------------------------------------------------------------- + +module GF.Devel.Compile.SourceToGF ( + transGrammar, + transModDef, + transExp, +---- transOldGrammar, +---- transInclude, + newReservedWords + ) where + +import qualified GF.Devel.Grammar.Grammar as G +import GF.Devel.Grammar.Construct +import qualified GF.Devel.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.Infra.Ident +import GF.Devel.Compile.AbsGF +import GF.Devel.Compile.PrintGF (printTree) +----import GF.Source.PrintGF +----import GF.Compile.RemoveLiT --- for bw compat +import GF.Data.Operations +--import GF.Infra.Option + +import Control.Monad +import Data.Char +import qualified Data.Map as Map +import Data.List (genericReplicate) + +import Debug.Trace (trace) ---- + +-- based on the skeleton Haskell module generated by the BNF converter + +type Result = Err String + +failure :: Show a => a -> Err b +failure x = Bad $ "Undefined case: " ++ show x + +getIdentPos :: PIdent -> Err (Ident,Int) +getIdentPos x = case x of + PIdent ((line,_),c) -> return (IC c,line) + +transIdent :: PIdent -> Err Ident +transIdent = liftM fst . getIdentPos + +transName :: Name -> Err Ident +transName n = case n of + PIdentName i -> transIdent i + ListName i -> transIdent (mkListId i) + +transGrammar :: Grammar -> Err G.GF +transGrammar x = case x of + Gr moddefs -> do + moddefs' <- mapM transModDef moddefs + let mos = Map.fromList moddefs' + return $ emptyGF {G.gfmodules = mos} + +transModDef :: ModDef -> Err (Ident, G.Module) +transModDef x = case x of + MModule compl mtyp body -> do + + let isCompl = transComplMod compl + + (trDef, mtyp', id') <- case mtyp of + MAbstract id -> do + id' <- transIdent id + return (transAbsDef, G.MTAbstract, id') + MGrammar id -> mkModRes id G.MTGrammar body + MResource id -> mkModRes id G.MTGrammar body + MConcrete id open -> do + id' <- transIdent id + open' <- transIdent open + return (transCncDef, G.MTConcrete open', id') + MInterface id -> mkModRes id G.MTInterface body + MInstance id open -> do + open' <- transIdent open + mkModRes id (G.MTInstance open') body + + mkBody (isCompl, trDef, mtyp', id') body + where + mkBody xx@(isc, trDef, mtyp', id') bod = case bod of + MNoBody incls -> do + mkBody xx $ MBody (Ext incls) NoOpens [] + MBody extends opens defs -> do + extends' <- transExtend extends + opens' <- transOpens opens + defs0 <- mapM trDef $ getTopDefs defs + let defs' = Map.fromListWith unifyJudgements + [(i,d) | Left ds <- defs0, (i,d) <- ds] + let flags' = Map.fromList [f | Right fs <- defs0, f <- fs] + return (id', G.Module mtyp' isc [] [] extends' opens' flags' defs') + + MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens [] + MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs + MWithE extends m insts -> mkBody xx $ MWithEBody extends m insts NoOpens [] + MWithEBody extends m insts opens defs -> do + extends' <- mapM transIncludedExt extends + m' <- transIncludedExt m + insts' <- mapM transOpen insts + opens' <- transOpens opens + defs0 <- mapM trDef $ getTopDefs defs + let defs' = Map.fromListWith unifyJudgements + [(i,d) | Left ds <- defs0, (i,d) <- ds] + let flags' = Map.fromList [f | Right fs <- defs0, f <- fs] + return (id', G.Module mtyp' isc [] [(m',insts')] extends' opens' flags' defs') + _ -> fail "deprecated module form" + + + mkModRes id mtyp body = do + id' <- transIdent id + return (transResDef, mtyp, id') + + +getTopDefs :: [TopDef] -> [TopDef] +getTopDefs x = x + +transComplMod :: ComplMod -> Bool +transComplMod x = case x of + CMCompl -> True + CMIncompl -> False + +transExtend :: Extend -> Err [(Ident,G.MInclude)] +transExtend x = case x of + Ext ids -> mapM transIncludedExt ids + NoExt -> return [] + +transOpens :: Opens -> Err [(Ident,Ident)] +transOpens x = case x of + NoOpens -> return [] + OpenIn opens -> mapM transOpen opens + +transOpen :: Open -> Err (Ident,Ident) +transOpen x = case x of + OName id -> transIdent id >>= \y -> return (y,y) + OQual id m -> liftM2 (,) (transIdent id) (transIdent m) + +transIncludedExt :: Included -> Err (Ident, G.MInclude) +transIncludedExt x = case x of + IAll i -> liftM2 (,) (transIdent i) (return G.MIAll) + ISome i ids -> liftM2 (,) (transIdent i) (liftM G.MIOnly $ mapM transIdent ids) + IMinus i ids -> liftM2 (,) (transIdent i) (liftM G.MIExcept $ mapM transIdent ids) + +transAbsDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)]) +transAbsDef x = case x of + DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs + DefFun fundefs -> do + fundefs' <- mapM transFunDef fundefs + returnl [(fun, absFun typ) | (funs,typ) <- fundefs', fun <- funs] +{- ---- + DefFunData fundefs -> do + fundefs' <- mapM transFunDef fundefs + returnl $ + [(cat, G.AbsCat nope (yes [M.cn fun])) | (funs,typ) <- fundefs', + fun <- funs, + Ok (_,cat) <- [M.valCat typ] + ] ++ + [(fun, G.AbsFun (yes typ) (yes G.EData)) | (funs,typ) <- fundefs', fun <- funs] + DefDef defs -> do + defs' <- liftM concat $ mapM getDefsGen defs + returnl [(c, G.AbsFun nope pe) | (c,(_,pe)) <- defs'] + DefData ds -> do + ds' <- mapM transDataDef ds + returnl $ + [(c, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++ + [(f, G.AbsFun nope (yes G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf] +-} + DefFlag defs -> liftM (Right . concat) $ mapM transFlagDef defs + _ -> return $ Left [] ---- +---- _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x + where + -- to get data constructors as terms + funs t = case t of + G.Con f -> [f] + G.Q _ f -> [f] + G.QC _ f -> [f] + _ -> [] + +returnl :: a -> Err (Either a b) +returnl = return . Left + +transFlagDef :: Def -> Err [(Ident,String)] +transFlagDef x = case x of + DDef f x -> do + fs <- mapM transName f + x' <- transExp x + v <- case x' of + G.K s -> return s + G.Vr (IC s) -> return s + G.EInt i -> return $ show i + _ -> fail $ "illegal flag value" +++ printTree x + return $ [(f',v) | f' <- fs] + + +-- | Cat definitions can also return some fun defs +-- if it is a list category definition +transCatDef :: CatDef -> Err [(Ident, G.Judgement)] +transCatDef x = case x of + SimpleCatDef id ddecls -> liftM (:[]) $ cat id ddecls + ListCatDef id ddecls -> listCat id ddecls 0 + ListSizeCatDef id ddecls size -> listCat id ddecls size + where + cat id ddecls = do + i <- transIdent id + cont <- liftM concat $ mapM transDDecl ddecls + return (i, absCat cont) + listCat id ddecls size = do + let li = mkListId id + li' <- transIdent $ li + baseId <- transIdent $ mkBaseId id + consId <- transIdent $ mkConsId id + catd0@(c,ju) <- cat li ddecls + id' <- transIdent id + let + cont0 = [] ---- cat context + catd = (c,ju) ----(Yes cont0) (Yes [M.cn baseId,M.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) + lc = M.mkApp (G.Vr li') xs + niltyp = mkProd (cont ++ genericReplicate size cd) lc + nilfund = (baseId, absFun niltyp) ---- (yes niltyp) (yes G.EData)) + 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 + +transFunDef :: FunDef -> Err ([Ident], G.Type) +transFunDef x = case x of + FDecl ids typ -> liftM2 (,) (mapM transName ids) (transExp typ) + +{- ---- +transDataDef :: DataDef -> Err (Ident,[G.Term]) +transDataDef x = case x of + DataDef id ds -> liftM2 (,) (transIdent id) (mapM transData ds) + where + transData d = case d of + DataId id -> liftM G.Con $ transIdent id + DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id) +-} + +transResDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)]) +transResDef x = case x of + DefPar pardefs -> do + pardefs' <- mapM transParDef pardefs + returnl $ concatMap mkParamDefs pardefs' + + DefOper defs -> do + defs' <- liftM concat $ mapM getDefs defs + returnl $ concatMap mkOverload [(f, resOper pt pe) | (f,(pt,pe)) <- defs'] + + DefLintype defs -> do + defs' <- liftM concat $ mapM getDefs defs + returnl [(f, resOper pt pe) | (f,(pt,pe)) <- defs'] + + DefFlag defs -> liftM (Right . concat) $ mapM transFlagDef defs + _ -> Bad $ "illegal definition form in resource" +++ printTree x + where + + mkParamDefs (p,pars) = + if null pars + then [(p,addJType M.meta0 (emptyJudgement G.JParam))] -- in an interface + else (p,resParam pars) : paramConstructors p pars + + mkOverload (c,j) = case (G.jtype j, G.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.App keyw (G.RecType fs@(_:_:_)),_) | isOverloading keyw c fs -> [] + _ -> [(c,j)] + isOverloading (G.Vr keyw) c fs = + prIdent keyw == "overload" && -- overload is a "soft keyword" + True ---- all (== GP.prt c) (map (GP.prt . fst) fs) + +transParDef :: ParDef -> Err (Ident, [(Ident,G.Context)]) +transParDef x = case x of + ParDefDir id params -> liftM2 (,) (transIdent id) (mapM transParConstr params) + ParDefAbs id -> liftM2 (,) (transIdent id) (return []) + +transCncDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)]) +transCncDef x = case x of + DefLincat defs -> do + defs' <- liftM concat $ mapM transPrintDef defs + returnl [(f, cncCat t) | (f,t) <- defs'] +---- DefLindef defs -> do +---- defs' <- liftM concat $ mapM getDefs defs +---- returnl [(f, G.CncCat pt pe nope) | (f,(pt,pe)) <- defs'] + DefLin defs -> do + defs' <- liftM concat $ mapM getDefs defs + returnl [(f, cncFun pe) | (f,(_,pe)) <- defs'] +{- ---- + DefPrintCat defs -> do + defs' <- liftM concat $ mapM transPrintDef defs + returnl [(f, G.CncCat nope nope (yes e)) | (f,e) <- defs'] + DefPrintFun defs -> do + defs' <- liftM concat $ mapM transPrintDef defs + returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] + DefPrintOld defs -> do --- a guess, for backward compatibility + defs' <- liftM concat $ mapM transPrintDef defs + returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] + DefFlag defs -> liftM Right $ mapM transFlagDef defs + DefPattern defs -> do + defs' <- liftM concat $ mapM getDefs defs + let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs'] + returnl [(f, G.CncFun Nothing (yes t) nope) | (f,t) <- defs2] +-} + _ -> errIn ("illegal definition in concrete syntax:") $ transResDef x + +transPrintDef :: Def -> Err [(Ident,G.Term)] +transPrintDef x = case x of + DDef ids exp -> do + (ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp) + return $ [(i,e) | i <- ids] + +getDefsGen :: Def -> Err [(Ident, (G.Type, G.Term))] +getDefsGen d = case d of + DDecl ids t -> do + ids' <- mapM transName ids + t' <- transExp t + return [(i,(t', nope)) | i <- ids'] + DDef ids e -> do + ids' <- mapM transName ids + e' <- transExp e + return [(i,(nope, yes e')) | i <- ids'] + DFull ids t e -> do + ids' <- mapM transName ids + t' <- transExp t + e' <- transExp e + return [(i,(yes t', yes e')) | i <- ids'] + DPatt id patts e -> do + id' <- transName id + ps' <- mapM transPatt patts + e' <- transExp e + return [(id',(nope, yes (G.Eqs [(ps',e')])))] + where + yes = id + nope = G.Meta 0 + +-- | sometimes you need this special case, e.g. in linearization rules +getDefs :: Def -> Err [(Ident, (G.Type, G.Term))] +getDefs d = case d of + DPatt id patts e -> do + id' <- transName id + xs <- mapM tryMakeVar patts + e' <- transExp e + return [(id',(nope, (M.mkAbs xs e')))] + _ -> getDefsGen d + where + nope = G.Meta 0 + +-- | accepts a pattern that is either a variable or a wild card +tryMakeVar :: Patt -> Err Ident +tryMakeVar p = do + p' <- transPatt p + case p' of + G.PV i -> return i + G.PW -> return identW + _ -> Bad $ "not a legal pattern in lambda binding" +++ show p' + +transExp :: Exp -> Err G.Term +transExp x = case x of + EPIdent id -> liftM G.Vr $ transIdent id + EConstr id -> liftM G.Con $ transIdent id + ECons id -> liftM G.Con $ transIdent id + 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 + EInt n -> return $ G.EInt n + EFloat n -> return $ G.EFloat n + EMeta -> return $ G.Meta 0 + EEmpty -> return G.Empty + -- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n) + EList i es -> transExp $ foldl EApp (EPIdent (mkListId i)) (exps2list es) + EStrings [] -> return G.Empty + EStrings str -> return $ foldr1 G.C $ map G.K $ words str + ERecord defs -> erecord2term defs + ETupTyp _ _ -> do + let tups t = case t of + ETupTyp x y -> tups x ++ [y] -- right-associative parsing + _ -> [t] + es <- mapM transExp $ tups x + return $ G.RecType $ [] ---- M.tuple2recordType es + ETuple tuplecomps -> do + es <- mapM transExp [e | TComp e <- tuplecomps] + return $ G.R $ [] ---- M.tuple2record es + EProj exp id -> liftM2 G.P (transExp exp) (trLabel id) + EApp exp0 exp -> liftM2 G.App (transExp exp0) (transExp exp) + ETable cases -> liftM (G.T G.TRaw) (transCases cases) + ETTable exp cases -> + liftM2 (\t c -> G.T (G.TTyped t) c) (transExp exp) (transCases cases) + EVTable exp cases -> + liftM2 (\t c -> G.V t c) (transExp exp) (mapM transExp cases) + ECase exp cases -> do + exp' <- transExp exp + cases' <- transCases cases + let annot = case exp' of + G.Typed _ t -> G.TTyped t + _ -> G.TRaw + return $ G.S (G.T annot cases') exp' + ECTable binds exp -> liftM2 M.mkCTable (mapM transBind binds) (transExp exp) + + EVariants exps -> liftM G.FV $ mapM transExp exps + EPre exp alts -> liftM2 (curry G.Alts) (transExp exp) (mapM transAltern alts) + EStrs exps -> liftM G.FV $ mapM transExp exps + ESelect exp0 exp -> liftM2 G.S (transExp exp0) (transExp exp) + EExtend exp0 exp -> liftM2 G.ExtR (transExp exp0) (transExp exp) + EAbstr binds exp -> liftM2 M.mkAbs (mapM transBind binds) (transExp exp) + ETyped exp0 exp -> liftM2 G.Typed (transExp exp0) (transExp exp) + EExample exp str -> liftM2 G.Example (transExp exp) (return str) + + EProd decl exp -> liftM2 mkProd (transDecl decl) (transExp exp) + ETType exp0 exp -> liftM2 G.Table (transExp exp0) (transExp exp) + EConcat exp0 exp -> liftM2 G.C (transExp exp0) (transExp exp) + EGlue exp0 exp -> liftM2 G.Glue (transExp exp0) (transExp exp) + ELet defs exp -> do + exp' <- transExp exp + defs0 <- mapM locdef2fields defs + defs' <- mapM tryLoc $ concat defs0 + return $ M.mkLet defs' exp' + where + tryLoc (c,(mty,Just e)) = return (c,(mty,e)) + tryLoc (c,_) = Bad $ "local definition of" +++ prIdent c +++ "without value" + ELetb defs exp -> transExp $ ELet defs exp + EWhere exp defs -> transExp $ ELet defs exp + + ELString (LString str) -> return $ G.K str +---- ELin id -> liftM G.LiT $ transIdent id + + EEqs eqs -> liftM G.Eqs $ mapM transEquation eqs + + _ -> Bad $ "translation not yet defined for" +++ printTree x ---- + +exps2list :: Exps -> [Exp] +exps2list NilExp = [] +exps2list (ConsExp e es) = e : exps2list es + +--- this is complicated: should we change Exp or G.Term ? + +erecord2term :: [LocDef] -> Err G.Term +erecord2term ds = do + ds' <- mapM locdef2fields ds + mkR $ concat ds' + where + mkR fs = do + fs' <- transF fs + return $ case fs' of + Left ts -> G.RecType ts + Right ds -> G.R ds + transF [] = return $ Left [] --- empty record always interpreted as record type + transF fs@(f:_) = case f of + (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) + _ -> Bad $ "illegal record type field" +++ show (fst f) --- manifest fields ?! + tryR f = case f of + (lab,(mty, Just t)) -> return (M.ident2label lab,(mty,t)) + _ -> Bad $ "illegal record field" +++ show (fst f) + + +locdef2fields :: LocDef -> Err [(Ident, (Maybe G.Type, Maybe G.Type))] +locdef2fields d = case d of + LDDecl ids t -> do + labs <- mapM transIdent ids + t' <- transExp t + return [(lab,(Just t',Nothing)) | lab <- labs] + LDDef ids e -> do + labs <- mapM transIdent ids + e' <- transExp e + return [(lab,(Nothing, Just e')) | lab <- labs] + LDFull ids t e -> do + labs <- mapM transIdent ids + t' <- transExp t + e' <- transExp e + return [(lab,(Just t', Just e')) | lab <- labs] + +trLabel :: Label -> Err G.Label +trLabel x = case x of + + -- this case is for bward compatibiity and should be removed + LPIdent (PIdent (_,'v':ds)) | all isDigit ds -> return $ G.LVar $ readIntArg ds + + LPIdent (PIdent (_, s)) -> return $ G.LIdent s + LVar x -> return $ G.LVar $ fromInteger x + +transSort :: Sort -> Err String +transSort x = case x of + _ -> return $ printTree x + +transPatt :: Patt -> Err G.Patt +transPatt x = case x of + PW -> return wildPatt + PV id -> liftM G.PV $ transIdent id + PC id patts -> liftM2 G.PC (transIdent id) (mapM transPatt patts) + PCon id -> liftM2 G.PC (transIdent id) (return []) + PInt n -> return $ G.PInt n + PFloat n -> return $ G.PFloat n + PStr str -> return $ G.PString str + PR pattasss -> do + let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss] + ls = map LPIdent $ concat lss + liftM G.PR $ liftM2 zip (mapM trLabel ls) (mapM transPatt ps) + PTup pcs -> + liftM (G.PR . M.tuple2recordPatt) (mapM transPatt [e | PTComp e <- pcs]) + PQ id0 id -> liftM3 G.PP (transIdent id0) (transIdent id) (return []) + PQC id0 id patts -> + liftM3 G.PP (transIdent id0) (transIdent id) (mapM transPatt patts) + PDisj p1 p2 -> liftM2 G.PAlt (transPatt p1) (transPatt p2) + PSeq p1 p2 -> liftM2 G.PSeq (transPatt p1) (transPatt p2) + PRep p -> liftM G.PRep (transPatt p) + PNeg p -> liftM G.PNeg (transPatt p) + PAs x p -> liftM2 G.PAs (transIdent x) (transPatt p) + + + +transBind :: Bind -> Err Ident +transBind x = case x of + BPIdent id -> transIdent id + BWild -> return identW + +transDecl :: Decl -> Err [G.Decl] +transDecl x = case x of + DDec binds exp -> do + xs <- mapM transBind binds + exp' <- transExp exp + return [(x,exp') | x <- xs] + DExp exp -> liftM (return . M.mkDecl) $ transExp exp + +transCases :: [Case] -> Err [G.Case] +transCases = mapM transCase + +transCase :: Case -> Err G.Case +transCase (Case p exp) = do + patt <- transPatt p + exp' <- transExp exp + return (patt,exp') + +transEquation :: Equation -> Err G.Equation +transEquation x = case x of + Equ apatts exp -> liftM2 (,) (mapM transPatt apatts) (transExp exp) + +transAltern :: Altern -> Err (G.Term, G.Term) +transAltern x = case x of + Alt exp0 exp -> liftM2 (,) (transExp exp0) (transExp exp) + +transParConstr :: ParConstr -> Err (Ident,G.Context) +transParConstr x = case x of + ParConstr id ddecls -> do + id' <- transIdent id + ddecls' <- mapM transDDecl ddecls + return (id',concat ddecls') + +transDDecl :: DDecl -> Err [G.Decl] +transDDecl x = case x of + DDDec binds exp -> transDecl $ DDec binds exp + DDExp exp -> transDecl $ DExp exp + +{- ---- +-- | to deal with the old format, sort judgements in three modules, forming +-- their names from a given string, e.g. file name or overriding user-given string +transOldGrammar :: Options -> FilePath -> OldGrammar -> Err G.SourceGrammar +transOldGrammar opts name0 x = case x of + OldGr includes topdefs -> do --- includes must be collected separately + let moddefs = sortTopDefs topdefs + g1 <- transGrammar $ Gr moddefs + removeLiT g1 --- needed for bw compatibility with an obsolete feature + where + sortTopDefs ds = [mkAbs a,mkRes ops r,mkCnc ops c] ++ map mkPack ps + where + ops = map fst ps + (a,r,c,ps) = foldr srt ([],[],[],[]) ds + srt d (a,r,c,ps) = case d of + DefCat catdefs -> (d:a,r,c,ps) + DefFun fundefs -> (d:a,r,c,ps) + DefFunData fundefs -> (d:a,r,c,ps) + DefDef defs -> (d:a,r,c,ps) + DefData pardefs -> (d:a,r,c,ps) + DefPar pardefs -> (a,d:r,c,ps) + DefOper defs -> (a,d:r,c,ps) + DefLintype defs -> (a,d:r,c,ps) + DefLincat defs -> (a,r,d:c,ps) + DefLindef defs -> (a,r,d:c,ps) + DefLin defs -> (a,r,d:c,ps) + DefPattern defs -> (a,r,d:c,ps) + DefFlag defs -> (a,r,d:c,ps) --- a guess + DefPrintCat printdefs -> (a,r,d:c,ps) + DefPrintFun printdefs -> (a,r,d:c,ps) + DefPrintOld printdefs -> (a,r,d:c,ps) + DefPackage m ds -> (a,r,c,(m,ds):ps) + _ -> (a,r,c,ps) + mkAbs a = MModule q (MTAbstract absName) (MBody ne (OpenIn []) (topDefs a)) + mkRes ps r = MModule q (MTResource resName) (MBody ne (OpenIn ops) (topDefs r)) + where ops = map OName ps + mkCnc ps r = MModule q (MTConcrete cncName absName) + (MBody ne (OpenIn (map OName (resName:ps))) (topDefs r)) + mkPack (m, ds) = MModule q (MTResource m) (MBody ne (OpenIn []) (topDefs ds)) + topDefs t = t + ne = NoExt + q = CMCompl + + name = maybe name0 (++ ".gf") $ getOptVal opts useName + absName = identC $ maybe topic id $ getOptVal opts useAbsName + resName = identC $ maybe ("Res" ++ lang) id $ getOptVal opts useResName + cncName = identC $ maybe lang id $ getOptVal opts useCncName + + (beg,rest) = span (/='.') name + (topic,lang) = case rest of -- to avoid overwriting old files + ".gf" -> ("Abs" ++ beg,"Cnc" ++ beg) + ".cf" -> ("Abs" ++ beg,"Cnc" ++ beg) + ".ebnf" -> ("Abs" ++ beg,"Cnc" ++ beg) + [] -> ("Abs" ++ beg,"Cnc" ++ beg) + _:s -> (beg, takeWhile (/='.') s) + +transInclude :: Include -> Err [FilePath] +transInclude x = case x of + NoIncl -> return [] + Incl filenames -> return $ map trans filenames + where + trans f = case f of + FString s -> s + FIdent (IC s) -> modif s + FSlash filename -> '/' : trans filename + FDot filename -> '.' : trans filename + FMinus filename -> '-' : trans filename + FAddId (IC s) filename -> modif s ++ trans filename + modif s = let s' = init s ++ [toLower (last s)] in + if elem s' newReservedWords then s' else s + --- unsafe hack ; cf. GetGrammar.oldLexer +-} + +newReservedWords :: [String] +newReservedWords = + words $ "abstract concrete interface incomplete " ++ + "instance out open resource reuse transfer union with where" + +termInPattern :: G.Term -> G.Term +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" + (xx,body) = abss [] t + abss xs t = case t of + G.Abs x b -> abss (x:xs) b + _ -> (reverse xs,t) + +mkListId,mkConsId,mkBaseId :: PIdent -> PIdent +mkListId = prefixId "List" +mkConsId = prefixId "Cons" +mkBaseId = prefixId "Base" + +prefixId :: String -> PIdent -> PIdent +prefixId pref (PIdent (p,id)) = PIdent (p, pref ++ id) diff --git a/src/GF/Devel/Grammar/AppPredefined.hs b/src/GF/Devel/Grammar/AppPredefined.hs index 41abf4886..c8d2988fd 100644 --- a/src/GF/Devel/Grammar/AppPredefined.hs +++ b/src/GF/Devel/Grammar/AppPredefined.hs @@ -18,7 +18,8 @@ module GF.Devel.Grammar.AppPredefined ( appPredefined ) where -import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.Macros import GF.Devel.Grammar.PrGF (prt,prt_,prtBad) import GF.Infra.Ident diff --git a/src/GF/Devel/Grammar/Compute.hs b/src/GF/Devel/Grammar/Compute.hs index 82417ec99..449cd3b90 100644 --- a/src/GF/Devel/Grammar/Compute.hs +++ b/src/GF/Devel/Grammar/Compute.hs @@ -18,8 +18,8 @@ module GF.Devel.Grammar.Compute ( computeTermRec ) where -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.Macros import GF.Devel.Grammar.Lookup import GF.Devel.Grammar.PrGF diff --git a/src/GF/Devel/Grammar/Construct.hs b/src/GF/Devel/Grammar/Construct.hs new file mode 100644 index 000000000..92e88b577 --- /dev/null +++ b/src/GF/Devel/Grammar/Construct.hs @@ -0,0 +1,216 @@ +module GF.Devel.Grammar.Construct where + +import GF.Devel.Grammar.Grammar +import GF.Infra.Ident + +import GF.Data.Operations + +import Control.Monad +import Data.Map +import Debug.Trace (trace) + +------------------ +-- abstractions on Grammar +------------------ + +-- abstractions on GF + +emptyGF :: GF +emptyGF = GF Nothing [] empty empty + +type SourceModule = (Ident,Module) + +listModules :: GF -> [SourceModule] +listModules = assocs.gfmodules + +addModule :: Ident -> Module -> GF -> GF +addModule c m gf = gf {gfmodules = insert c m (gfmodules gf)} + +-- abstractions on Module + +emptyModule :: Ident -> Module +emptyModule m = Module MTGrammar True [] [] [] [] empty empty + +isCompleteModule :: Module -> Bool +isCompleteModule = miscomplete + +isInterface :: Module -> Bool +isInterface m = case mtype m of + MTInterface -> True + MTAbstract -> True + _ -> False + +interfaceName :: Module -> Maybe Ident +interfaceName mo = case mtype mo of + MTInstance i -> return i + MTConcrete i -> return i + _ -> Nothing + +listJudgements :: Module -> [(Ident,Judgement)] +listJudgements = assocs . mjments + +isInherited :: MInclude -> Ident -> Bool +isInherited mi i = case mi of + MIExcept is -> notElem i is + MIOnly is -> elem i is + _ -> True + +-- abstractions on Judgement + +isConstructor :: Judgement -> Bool +isConstructor j = jdef j == EData + +isLink :: Judgement -> Bool +isLink j = jform j == JLink + +-- constructing judgements from parse tree + +emptyJudgement :: JudgementForm -> Judgement +emptyJudgement form = Judgement form meta meta meta (identC "#NOLINK") 0 where + meta = Meta 0 + +addJType :: Type -> Judgement -> Judgement +addJType tr ju = ju {jtype = tr} + +addJDef :: Term -> Judgement -> Judgement +addJDef tr ju = ju {jdef = tr} + +addJPrintname :: Term -> Judgement -> Judgement +addJPrintname tr ju = ju {jprintname = tr} + +linkInherited :: Bool -> Ident -> Judgement +linkInherited can mo = (emptyJudgement JLink){ + jlink = mo, + jdef = if can then EData else Meta 0 + } + +absCat :: Context -> Judgement +absCat co = addJType (mkProd co typeType) (emptyJudgement JCat) + +absFun :: Type -> Judgement +absFun ty = addJType ty (emptyJudgement JFun) + +cncCat :: Type -> Judgement +cncCat ty = addJType ty (emptyJudgement JLincat) + +cncFun :: Term -> Judgement +cncFun tr = addJDef tr (emptyJudgement JLin) + +resOperType :: Type -> Judgement +resOperType ty = addJType ty (emptyJudgement JOper) + +resOperDef :: Term -> Judgement +resOperDef tr = addJDef tr (emptyJudgement JOper) + +resOper :: Type -> Term -> Judgement +resOper ty tr = addJDef tr (resOperType ty) + +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 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 + +---- used in SourceToGF; make error-free and informative +unifyJudgements j k = case unifyJudgement j k of + Ok l -> l + Bad s -> error s + +unifyJudgement :: Judgement -> Judgement -> Err Judgement +unifyJudgement old new = do + testErr (jform old == jform new) "different judment forms" + [jty,jde,jpri] <- mapM unifyField [jtype,jdef,jprintname] + return $ old{jtype = jty, jdef = jde, jprintname = jpri} + where + unifyField field = unifyTerm (field old) (field new) + unifyTerm oterm nterm = case (oterm,nterm) of + (Meta _,t) -> return t + (t,Meta _) -> return t + _ -> do + if (nterm /= oterm) + then (trace (unwords ["illegal update of",show oterm,"to",show nterm]) + (return ())) + else return () ---- to recover from spurious qualification conflicts +---- testErr (nterm == oterm) +---- (unwords ["illegal update of",prt oterm,"to",prt nterm]) + return nterm + + + +-- abstractions on Term + +type Cat = QIdent +type Fun = QIdent +type QIdent = (Ident,Ident) + +-- | branches à la Alfa +newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read) +type Con = Ident --- + +varLabel :: Int -> Label +varLabel = LVar + +wildPatt :: Patt +wildPatt = PW + +type Trm = Term + +mkProd :: Context -> Type -> Type +mkProd = flip (foldr (uncurry Prod)) + +-- type constants + +typeType :: Type +typeType = Sort "Type" + +typePType :: Type +typePType = Sort "PType" + +typeStr :: Type +typeStr = Sort "Str" + +typeTok :: Type ---- deprecated +typeTok = Sort "Tok" + +cPredef :: Ident +cPredef = identC "Predef" + +cPredefAbs :: Ident +cPredefAbs = identC "PredefAbs" + +typeString, typeFloat, typeInt :: Term +typeInts :: Integer -> Term + +typeString = constPredefRes "String" +typeInt = constPredefRes "Int" +typeFloat = constPredefRes "Float" +typeInts i = App (constPredefRes "Ints") (EInt i) + +isTypeInts :: Term -> Bool +isTypeInts ty = case ty of + App c _ -> c == constPredefRes "Ints" + _ -> False + +cnPredef = constPredefRes + +constPredefRes :: String -> Term +constPredefRes s = Q (IC "Predef") (identC s) + +isPredefConstant :: Term -> Bool +isPredefConstant t = case t of + Q (IC "Predef") _ -> True + Q (IC "PredefAbs") _ -> True + _ -> False + + diff --git a/src/GF/Devel/Grammar/GF.cf b/src/GF/Devel/Grammar/GF.cf deleted file mode 100644 index 6fc9307b2..000000000 --- a/src/GF/Devel/Grammar/GF.cf +++ /dev/null @@ -1,319 +0,0 @@ --- AR 2/5/2003, 14-16 o'clock, Torino - --- 17/6/2007: marked with suffix --% those lines that are obsolete and --- should not be included in documentation - -entrypoints Grammar, ModDef, - OldGrammar, --% - Exp ; -- let's see if more are needed - -comment "--" ; -comment "{-" "-}" ; - - --- identifiers - -position token PIdent (letter | '_') (letter | digit | '_' | '\'')* ; - --- the top-level grammar - -Gr. Grammar ::= [ModDef] ; - --- semicolon after module is permitted but not obligatory - -terminator ModDef "" ; -_. ModDef ::= ModDef ";" ; - --- the individual modules - -MModule. ModDef ::= ComplMod ModType "=" ModBody ; - -MAbstract. ModType ::= "abstract" PIdent ; -MResource. ModType ::= "resource" PIdent ; -MGrammar. ModType ::= "grammar" PIdent ; -MInterface. ModType ::= "interface" PIdent ; -MConcrete. ModType ::= "concrete" PIdent "of" PIdent ; -MInstance. ModType ::= "instance" PIdent "of" PIdent ; - -MBody. ModBody ::= Extend Opens "{" [TopDef] "}" ; -MNoBody. ModBody ::= [Included] ; -MWith. ModBody ::= Included "with" [Open] ; -MWithBody. ModBody ::= Included "with" [Open] "**" Opens "{" [TopDef] "}" ; -MWithE. ModBody ::= [Included] "**" Included "with" [Open] ; -MWithEBody. ModBody ::= [Included] "**" Included "with" [Open] "**" Opens "{" [TopDef] "}" ; - -MReuse. ModBody ::= "reuse" PIdent ; --% -MUnion. ModBody ::= "union" [Included] ;--% - -separator TopDef "" ; - -Ext. Extend ::= [Included] "**" ; -NoExt. Extend ::= ; - -separator Open "," ; -NoOpens. Opens ::= ; -OpenIn. Opens ::= "open" [Open] "in" ; - -OName. Open ::= PIdent ; --- OQualQO. Open ::= "(" PIdent ")" ; --% -OQual. Open ::= "(" PIdent "=" PIdent ")" ; - -CMCompl. ComplMod ::= ; -CMIncompl. ComplMod ::= "incomplete" ; - -separator Included "," ; - -IAll. Included ::= PIdent ; -ISome. Included ::= PIdent "[" [PIdent] "]" ; -IMinus. Included ::= PIdent "-" "[" [PIdent] "]" ; - --- top-level definitions - -DefCat. TopDef ::= "cat" [CatDef] ; -DefFun. TopDef ::= "fun" [FunDef] ; -DefFunData.TopDef ::= "data" [FunDef] ; -DefDef. TopDef ::= "def" [Def] ; -DefData. TopDef ::= "data" [DataDef] ; - -DefPar. TopDef ::= "param" [ParDef] ; -DefOper. TopDef ::= "oper" [Def] ; - -DefLincat. TopDef ::= "lincat" [Def] ; -DefLindef. TopDef ::= "lindef" [Def] ; -DefLin. TopDef ::= "lin" [Def] ; - -DefPrintCat. TopDef ::= "printname" "cat" [Def] ; -DefPrintFun. TopDef ::= "printname" "fun" [Def] ; -DefFlag. TopDef ::= "flags" [Def] ; - --- definitions after most keywords - -DDecl. Def ::= [Name] ":" Exp ; -DDef. Def ::= [Name] "=" Exp ; -DPatt. Def ::= Name [Patt] "=" Exp ; -- non-empty pattern list -DFull. Def ::= [Name] ":" Exp "=" Exp ; - -FDecl. FunDef ::= [Name] ":" Exp ; - -SimpleCatDef. CatDef ::= PIdent [DDecl] ; -ListCatDef. CatDef ::= "[" PIdent [DDecl] "]" ; -ListSizeCatDef. CatDef ::= "[" PIdent [DDecl] "]" "{" Integer "}" ; - -DataDef. DataDef ::= Name "=" [DataConstr] ; -DataId. DataConstr ::= PIdent ; -DataQId. DataConstr ::= PIdent "." PIdent ; -separator DataConstr "|" ; - -ParDefDir. ParDef ::= PIdent "=" [ParConstr] ; -ParDefAbs. ParDef ::= PIdent ; - -ParConstr. ParConstr ::= PIdent [DDecl] ; - -terminator nonempty Def ";" ; -terminator nonempty FunDef ";" ; -terminator nonempty CatDef ";" ; -terminator nonempty DataDef ";" ; -terminator nonempty ParDef ";" ; - -separator ParConstr "|" ; - -separator nonempty PIdent "," ; - --- names of categories and functions in definition LHS - -PIdentName. Name ::= PIdent ; -ListName. Name ::= "[" PIdent "]" ; - -separator nonempty Name "," ; - --- definitions in records and $let$ expressions - -LDDecl. LocDef ::= [PIdent] ":" Exp ; -LDDef. LocDef ::= [PIdent] "=" Exp ; -LDFull. LocDef ::= [PIdent] ":" Exp "=" Exp ; - -separator LocDef ";" ; - --- terms and types - -EPIdent. Exp6 ::= PIdent ; -EConstr. Exp6 ::= "{" PIdent "}" ;--% -ECons. Exp6 ::= "%" PIdent "%" ;--% -ESort. Exp6 ::= Sort ; -EString. Exp6 ::= String ; -EInt. Exp6 ::= Integer ; -EFloat. Exp6 ::= Double ; -EMeta. Exp6 ::= "?" ; -EEmpty. Exp6 ::= "[" "]" ; -EData. Exp6 ::= "data" ; -EList. Exp6 ::= "[" PIdent Exps "]" ; -EStrings. Exp6 ::= "[" String "]" ; -ERecord. Exp6 ::= "{" [LocDef] "}" ; -- ! -ETuple. Exp6 ::= "<" [TupleComp] ">" ; --- needed for separator "," -EIndir. Exp6 ::= "(" "in" PIdent ")" ; -- indirection, used in judgements --% -ETyped. Exp6 ::= "<" Exp ":" Exp ">" ; -- typing, used for annotations - -EProj. Exp5 ::= Exp5 "." Label ; -EQConstr. Exp5 ::= "{" PIdent "." PIdent "}" ; -- qualified constructor --% -EQCons. Exp5 ::= "%" PIdent "." PIdent ; -- qualified constant --% - -EApp. Exp4 ::= Exp4 Exp5 ; -ETable. Exp4 ::= "table" "{" [Case] "}" ; -ETTable. Exp4 ::= "table" Exp6 "{" [Case] "}" ; -EVTable. Exp4 ::= "table" Exp6 "[" [Exp] "]" ; -ECase. Exp4 ::= "case" Exp "of" "{" [Case] "}" ; -EVariants. Exp4 ::= "variants" "{" [Exp] "}" ; -EPre. Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ; -EStrs. Exp4 ::= "strs" "{" [Exp] "}" ; - -ESelect. Exp3 ::= Exp3 "!" Exp4 ; -ETupTyp. Exp3 ::= Exp3 "*" Exp4 ; -EExtend. Exp3 ::= Exp3 "**" Exp4 ; - -EGlue. Exp1 ::= Exp2 "+" Exp1 ; - -EConcat. Exp ::= Exp1 "++" Exp ; - -EAbstr. Exp ::= "\\" [Bind] "->" Exp ; -ECTable. Exp ::= "\\""\\" [Bind] "=>" Exp ; -EProd. Exp ::= Decl "->" Exp ; -ETType. Exp ::= Exp3 "=>" Exp ; -- these are thus right associative -ELet. Exp ::= "let" "{" [LocDef] "}" "in" Exp ; -ELetb. Exp ::= "let" [LocDef] "in" Exp ; -EWhere. Exp ::= Exp3 "where" "{" [LocDef] "}" ; -EEqs. Exp ::= "fn" "{" [Equation] "}" ; --% - -EExample. Exp ::= "in" Exp5 String ; - -coercions Exp 6 ; - -separator Exp ";" ; -- in variants - --- list of arguments to category -NilExp. Exps ::= ; -ConsExp. Exps ::= Exp6 Exps ; -- Exp6 to force parantheses - --- patterns - -PW. Patt2 ::= "_" ; -PV. Patt2 ::= PIdent ; -PCon. Patt2 ::= "{" PIdent "}" ; --% -PQ. Patt2 ::= PIdent "." PIdent ; -PInt. Patt2 ::= Integer ; -PFloat. Patt2 ::= Double ; -PStr. Patt2 ::= String ; -PR. Patt2 ::= "{" [PattAss] "}" ; -PTup. Patt2 ::= "<" [PattTupleComp] ">" ; -PC. Patt1 ::= PIdent [Patt] ; -PQC. Patt1 ::= PIdent "." PIdent [Patt] ; -PDisj. Patt ::= Patt "|" Patt1 ; -PSeq. Patt ::= Patt "+" Patt1 ; -PRep. Patt1 ::= Patt2 "*" ; -PAs. Patt1 ::= PIdent "@" Patt2 ; -PNeg. Patt1 ::= "-" Patt2 ; - -coercions Patt 2 ; - -PA. PattAss ::= [PIdent] "=" Patt ; - --- labels - -LPIdent. Label ::= PIdent ; -LVar. Label ::= "$" Integer ; - --- basic types - -rules Sort ::= - "Type" - | "PType" - | "Tok" --% - | "Str" - | "Strs" ; - -separator PattAss ";" ; - --- this is explicit to force higher precedence level on rhs -(:[]). [Patt] ::= Patt2 ; -(:). [Patt] ::= Patt2 [Patt] ; - - --- binds in lambdas and lin rules - -BPIdent. Bind ::= PIdent ; -BWild. Bind ::= "_" ; - -separator Bind "," ; - - --- declarations in function types - -DDec. Decl ::= "(" [Bind] ":" Exp ")" ; -DExp. Decl ::= Exp4 ; -- can thus be an application - --- tuple component (term or pattern) - -TComp. TupleComp ::= Exp ; -PTComp. PattTupleComp ::= Patt ; - -separator TupleComp "," ; -separator PattTupleComp "," ; - --- case branches - -Case. Case ::= Patt "=>" Exp ; - -separator nonempty Case ";" ; - --- cases in abstract syntax --% - -Equ. Equation ::= [Patt] "->" Exp ; --% - -separator Equation ";" ; --% - --- prefix alternatives - -Alt. Altern ::= Exp "/" Exp ; - -separator Altern ";" ; - --- in a context, higher precedence is required than in function types - -DDDec. DDecl ::= "(" [Bind] ":" Exp ")" ; -DDExp. DDecl ::= Exp6 ; -- can thus *not* be an application - -separator DDecl "" ; - - --------------------------------------- --% - --- for backward compatibility --% - -OldGr. OldGrammar ::= Include [TopDef] ; --% - -NoIncl. Include ::= ; --% -Incl. Include ::= "include" [FileName] ; --% - -FString. FileName ::= String ; --% - -terminator nonempty FileName ";" ; --% - -FPIdent. FileName ::= PIdent ; --% -FSlash. FileName ::= "/" FileName ; --% -FDot. FileName ::= "." FileName ; --% -FMinus. FileName ::= "-" FileName ; --% -FAddId. FileName ::= PIdent FileName ; --% - -token LString '\'' (char - '\'')* '\'' ; --% -ELString. Exp6 ::= LString ; --% -ELin. Exp4 ::= "Lin" PIdent ; --% - -DefPrintOld. TopDef ::= "printname" [Def] ; --% -DefLintype. TopDef ::= "lintype" [Def] ; --% -DefPattern. TopDef ::= "pattern" [Def] ; --% - --- deprecated packages are attempted to be interpreted --% -DefPackage. TopDef ::= "package" PIdent "=" "{" [TopDef] "}" ";" ; --% - --- these two are just ignored after parsing --% -DefVars. TopDef ::= "var" [Def] ; --% -DefTokenizer. TopDef ::= "tokenizer" PIdent ";" ; --% diff --git a/src/GF/Devel/Grammar/GFtoSource.hs b/src/GF/Devel/Grammar/GFtoSource.hs index 2866c0446..9ac65469a 100644 --- a/src/GF/Devel/Grammar/GFtoSource.hs +++ b/src/GF/Devel/Grammar/GFtoSource.hs @@ -9,11 +9,10 @@ module GF.Devel.Grammar.GFtoSource ( ) where -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.Macros (contextOfType) -import qualified GF.Devel.Grammar.AbsGF as P +import qualified GF.Devel.Compile.AbsGF as P import GF.Infra.Ident import GF.Data.Operations @@ -43,7 +42,7 @@ trModule (i,mo) = P.MModule compl typ body where body = P.MBody (trExtends (mextends mo)) (mkOpens (map trOpen (mopens mo))) - (concatMap trAnyDef [(c,j) | (c,Left j) <- listJudgements mo] ++ + (concatMap trAnyDef [(c,j) | (c,j) <- listJudgements mo] ++ map trFlag (Map.assocs (mflags mo))) trExtends :: [(Ident,MInclude)] -> P.Extend @@ -89,6 +88,7 @@ trAnyDef (i,ju) = let JLin -> [P.DefLin [trDef i (Meta 0) (jdef ju)]] ---- ++ [P.DefPrintFun [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]] + JLink -> [] {- ---- encoding of AnyInd without changing syntax. AR 20/9/2007 AnyInd s b -> diff --git a/src/GF/Devel/Grammar/Grammar.hs b/src/GF/Devel/Grammar/Grammar.hs new file mode 100644 index 000000000..eb6d2218a --- /dev/null +++ b/src/GF/Devel/Grammar/Grammar.hs @@ -0,0 +1,161 @@ +module GF.Devel.Grammar.Grammar where + +import GF.Infra.Ident + +import GF.Data.Operations + +import Data.Map + + +------------------ +-- definitions -- +------------------ + +data GF = GF { + gfabsname :: Maybe Ident , + gfcncnames :: [Ident] , + gflags :: Map Ident String , -- value of a global flag + gfmodules :: Map Ident Module + } + +data Module = Module { + mtype :: ModuleType, + miscomplete :: Bool, + minterfaces :: [(Ident,Ident)], -- non-empty for functors + minstances :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for instant'ions + mextends :: [(Ident,MInclude)], + mopens :: [(Ident,Ident)], -- used name, original name + mflags :: Map Ident String, + mjments :: Map Ident Judgement + } + +data ModuleType = + MTAbstract + | MTConcrete Ident + | MTInterface + | MTInstance Ident + | MTGrammar + deriving Eq + +data MInclude = + MIAll + | MIExcept [Ident] + | MIOnly [Ident] + +type Indirection = (Ident,Bool) -- module of origin, whether canonical + +data Judgement = Judgement { + jform :: JudgementForm, -- cat fun lincat lin oper param + jtype :: Type, -- context type lincat - type constrs + jdef :: Term, -- lindef def lindef lin def values + jprintname :: Term, -- - - prname prname - - + jlink :: Ident, + jposition :: Int + } + +data JudgementForm = + JCat + | JFun + | JLincat + | JLin + | JOper + | JParam + | JLink + deriving Eq + +type Type = Term + +data Term = + Vr Ident -- ^ variable + | Con Ident -- ^ constructor + | EData -- ^ to mark in definition that a fun is a constructor + | Sort String -- ^ predefined type + | EInt Integer -- ^ integer literal + | EFloat Double -- ^ floating point literal + | K String -- ^ string literal or token: @\"foo\"@ + | Empty -- ^ the empty string @[]@ + + | App Term Term -- ^ application: @f a@ + | Abs Ident Term -- ^ abstraction: @\x -> b@ + | Meta MetaSymb -- ^ metavariable: @?i@ (only parsable: ? = ?0) + | Prod Ident Term Term -- ^ function type: @(x : A) -> B@ + | Eqs [Equation] -- ^ abstraction by cases: @fn {x y -> b ; z u -> c}@ + -- only used in internal representation + | Typed Term Term -- ^ type-annotated term +-- +-- /below this, the constructors are only for concrete syntax/ + | Example Term String -- ^ example-based term: @in M.C "foo" + | RecType [Labelling] -- ^ record type: @{ p : A ; ...}@ + | R [Assign] -- ^ record: @{ p = a ; ...}@ + | P Term Label -- ^ projection: @r.p@ + | PI Term Label Int -- ^ index-annotated projection + | ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms) + + | Table Term Term -- ^ table type: @P => A@ + | T TInfo [Case] -- ^ table: @table {p => c ; ...}@ + | V Type [Term] -- ^ course of values: @table T [c1 ; ... ; cn]@ + | S Term Term -- ^ selection: @t ! p@ + | Val Type Int -- ^ parameter value number: @T # i# + + | Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@ + + | Q Ident Ident -- ^ qualified constant from a module + | QC Ident Ident -- ^ qualified constructor from a module + + | C Term Term -- ^ concatenation: @s ++ t@ + | Glue Term Term -- ^ agglutination: @s + t@ + + | FV [Term] -- ^ free variation: @variants { s ; ... }@ + + | Alts (Term, [(Term, Term)]) -- ^ prefix-dependent: @pre {t ; s\/c ; ...}@ + + | Overload [(Type,Term)] + + deriving (Read, Show, Eq, Ord) + +data Patt = + PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@ + | PP Ident Ident [Patt] -- ^ qualified constr patt: @P.C p1 ... pn@ @P.C@ + | PV Ident -- ^ variable pattern: @x@ + | PW -- ^ wild card pattern: @_@ + | PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ + | PString String -- ^ string literal pattern: @\"foo\"@ + | PInt Integer -- ^ integer literal pattern: @12@ + | PFloat Double -- ^ float literal pattern: @1.2@ + | PT Type Patt -- ^ type-annotated pattern + | PAs Ident Patt -- ^ as-pattern: x@p + + -- regular expression patterns + | PNeg Patt -- ^ negated pattern: -p + | PAlt Patt Patt -- ^ disjunctive pattern: p1 | p2 + | PSeq Patt Patt -- ^ sequence of token parts: p + q + | PRep Patt -- ^ repetition of token part: p* + + deriving (Read, Show, Eq, Ord) + +-- | to guide computation and type checking of tables +data TInfo = + TRaw -- ^ received from parser; can be anything + | TTyped Type -- ^ type annotated, but can be anything + | TComp Type -- ^ expanded + | TWild Type -- ^ just one wild card pattern, no need to expand + deriving (Read, Show, Eq, Ord) + +-- | record label +data Label = + LIdent String + | LVar Int + deriving (Read, Show, Eq, Ord) + +type MetaSymb = Int + +type Decl = (Ident,Term) -- (x:A) (_:A) A +type Context = [Decl] -- (x:A)(y:B) (x,y:A) (_,_:A) +type Substitution = [(Ident, Term)] +type Equation = ([Patt],Term) + +type Labelling = (Label, Term) +type Assign = (Label, (Maybe Type, Term)) +type Case = (Patt, Term) +type LocalDef = (Ident, (Maybe Type, Term)) + diff --git a/src/GF/Devel/Grammar/Judgements.hs b/src/GF/Devel/Grammar/Judgements.hs deleted file mode 100644 index b09576e50..000000000 --- a/src/GF/Devel/Grammar/Judgements.hs +++ /dev/null @@ -1,21 +0,0 @@ -module GF.Devel.Grammar.Judgements where - -import GF.Devel.Grammar.Terms -import GF.Infra.Ident - -data Judgement = Judgement { - jform :: JudgementForm, -- cat fun lincat lin oper param - jtype :: Type, -- context type lincat - type constrs - jdef :: Term, -- lindef def lindef lin def values - jprintname :: Term -- - - prname prname - - - } - -data JudgementForm = - JCat - | JFun - | JLincat - | JLin - | JOper - | JParam - deriving Eq - diff --git a/src/GF/Devel/Grammar/Lookup.hs b/src/GF/Devel/Grammar/Lookup.hs index 756345f2e..ac55aec62 100644 --- a/src/GF/Devel/Grammar/Lookup.hs +++ b/src/GF/Devel/Grammar/Lookup.hs @@ -1,9 +1,8 @@ module GF.Devel.Grammar.Lookup where -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Judgements +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.Macros -import GF.Devel.Grammar.Terms import GF.Devel.Grammar.PrGF import GF.Infra.Ident @@ -103,15 +102,19 @@ lookupModule :: GF -> Ident -> Err Module lookupModule gf m = do maybe (raiseIdent "module not found:" m) return $ mlookup m (gfmodules gf) -lookupIdent :: GF -> Ident -> Ident -> Err JEntry +-- this finds the immediate definition, which can be a link +lookupIdent :: GF -> Ident -> Ident -> Err Judgement lookupIdent gf m c = do mo <- lookupModule gf m - maybe (raiseIdent "constant not found" c) return $ mlookup c (mjments mo) + maybe (raiseIdent "constant not found:" c) return $ mlookup c (mjments mo) +-- this follows the link lookupJudgement :: GF -> Ident -> Ident -> Err Judgement lookupJudgement gf m c = do - eji <- lookupIdent gf m c - either return (\n -> lookupJudgement gf (fst n) c) eji + ju <- lookupIdent gf m c + case jform ju of + JLink -> lookupJudgement gf (jlink ju) c + _ -> return ju mlookup = Data.Map.lookup diff --git a/src/GF/Devel/Grammar/Macros.hs b/src/GF/Devel/Grammar/Macros.hs index 0eebfda16..a9059578c 100644 --- a/src/GF/Devel/Grammar/Macros.hs +++ b/src/GF/Devel/Grammar/Macros.hs @@ -1,8 +1,7 @@ module GF.Devel.Grammar.Macros where -import GF.Devel.Grammar.Terms -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.Modules +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Infra.Ident import GF.Data.Str @@ -81,9 +80,6 @@ typeSkeleton typ = do -- construct types and terms -mkProd :: Context -> Type -> Type -mkProd = flip (foldr (uncurry Prod)) - mkFunType :: [Type] -> Type -> Type mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt]) t -- nondep prod @@ -156,49 +152,6 @@ plusRecord t1 t2 = zipAssign :: [Label] -> [Term] -> [Assign] zipAssign ls ts = [assign l t | (l,t) <- zip ls ts] --- type constants - -typeType :: Type -typeType = Sort "Type" - -typePType :: Type -typePType = Sort "PType" - -typeStr :: Type -typeStr = Sort "Str" - -typeTok :: Type ---- deprecated -typeTok = Sort "Tok" - -cPredef :: Ident -cPredef = identC "Predef" - -cPredefAbs :: Ident -cPredefAbs = identC "PredefAbs" - -typeString, typeFloat, typeInt :: Term -typeInts :: Integer -> Term - -typeString = constPredefRes "String" -typeInt = constPredefRes "Int" -typeFloat = constPredefRes "Float" -typeInts i = App (constPredefRes "Ints") (EInt i) - -isTypeInts :: Term -> Bool -isTypeInts ty = case ty of - App c _ -> c == constPredefRes "Ints" - _ -> False - -cnPredef = constPredefRes - -constPredefRes :: String -> Term -constPredefRes s = Q (IC "Predef") (identC s) - -isPredefConstant :: Term -> Bool -isPredefConstant t = case t of - Q (IC "Predef") _ -> True - Q (IC "PredefAbs") _ -> True - _ -> False defLinType :: Type defLinType = RecType [(LIdent "s", typeStr)] @@ -230,10 +183,8 @@ termOpModule f = judgementOpModule fj where judgementOpModule :: Monad m => (Judgement -> m Judgement) -> Module -> m Module judgementOpModule f m = do - mjs <- mapMapM fj (mjments m) + mjs <- mapMapM f (mjments m) return m {mjments = mjs} - where - fj = either (liftM Left . f) (return . Right) entryOpModule :: Monad m => (Ident -> Judgement -> m Judgement) -> Module -> m Module @@ -241,8 +192,7 @@ entryOpModule f m = do mjs <- liftM Map.fromAscList $ mapm $ Map.assocs $ mjments m return $ m {mjments = mjs} where - mapm = mapM (\ (i,j) -> liftM ((,) i) (fe i j)) - fe i j = either (liftM Left . f i) (return . Right) j + mapm = mapM (\ (i,j) -> liftM ((,) i) (f i j)) termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement termOpJudgement f j = do diff --git a/src/GF/Devel/Grammar/MkJudgements.hs b/src/GF/Devel/Grammar/MkJudgements.hs deleted file mode 100644 index 01b5f97d7..000000000 --- a/src/GF/Devel/Grammar/MkJudgements.hs +++ /dev/null @@ -1,93 +0,0 @@ -module GF.Devel.Grammar.MkJudgements where - -import GF.Devel.Grammar.Macros -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.Terms -import GF.Devel.Grammar.PrGF -import GF.Infra.Ident - -import GF.Data.Operations - -import Control.Monad -import Data.Map - -import Debug.Trace (trace) ---- - --- constructing judgements from parse tree - -emptyJudgement :: JudgementForm -> Judgement -emptyJudgement form = Judgement form meta meta meta where - meta = Meta 0 - -addJType :: Type -> Judgement -> Judgement -addJType tr ju = ju {jtype = tr} - -addJDef :: Term -> Judgement -> Judgement -addJDef tr ju = ju {jdef = tr} - -addJPrintname :: Term -> Judgement -> Judgement -addJPrintname tr ju = ju {jprintname = tr} - - -absCat :: Context -> Judgement -absCat co = addJType (mkProd co typeType) (emptyJudgement JCat) - -absFun :: Type -> Judgement -absFun ty = addJType ty (emptyJudgement JFun) - -cncCat :: Type -> Judgement -cncCat ty = addJType ty (emptyJudgement JLincat) - -cncFun :: Term -> Judgement -cncFun tr = addJDef tr (emptyJudgement JLin) - -resOperType :: Type -> Judgement -resOperType ty = addJType ty (emptyJudgement JOper) - -resOperDef :: Term -> Judgement -resOperDef tr = addJDef tr (emptyJudgement JOper) - -resOper :: Type -> Term -> Judgement -resOper ty tr = addJDef tr (resOperType ty) - -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 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 - ----- used in SourceToGF; make error-free and informative -unifyJudgements (Left j) (Left k) = Left $ case unifyJudgement j k of - Ok l -> l - Bad s -> error s - -unifyJudgement :: Judgement -> Judgement -> Err Judgement -unifyJudgement old new = do - testErr (jform old == jform new) "different judment forms" - [jty,jde,jpri] <- mapM unifyField [jtype,jdef,jprintname] - return $ old{jtype = jty, jdef = jde, jprintname = jpri} - where - unifyField field = unifyTerm (field old) (field new) - unifyTerm oterm nterm = case (oterm,nterm) of - (Meta _,t) -> return t - (t,Meta _) -> return t - _ -> do - if (nterm /= oterm) - then (trace (unwords ["illegal update of",prt oterm,"to",prt nterm]) - (return ())) - else return () ---- to recover from spurious qualification conflicts ----- testErr (nterm == oterm) ----- (unwords ["illegal update of",prt oterm,"to",prt nterm]) - return nterm - diff --git a/src/GF/Devel/Grammar/Modules.hs b/src/GF/Devel/Grammar/Modules.hs deleted file mode 100644 index 43458ce90..000000000 --- a/src/GF/Devel/Grammar/Modules.hs +++ /dev/null @@ -1,96 +0,0 @@ -module GF.Devel.Grammar.Modules where - -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.Terms -import GF.Infra.Ident - -import GF.Data.Operations - -import Control.Monad -import Data.Map - - -data GF = GF { - gfabsname :: Maybe Ident , - gfcncnames :: [Ident] , - gflags :: Map Ident String , -- value of a global flag - gfmodules :: Map Ident Module - } - -emptyGF :: GF -emptyGF = GF Nothing [] empty empty - -type SourceModule = (Ident,Module) - -listModules :: GF -> [SourceModule] -listModules = assocs.gfmodules - -addModule :: Ident -> Module -> GF -> GF -addModule c m gf = gf {gfmodules = insert c m (gfmodules gf)} - -data Module = Module { - mtype :: ModuleType, - miscomplete :: Bool, - minterfaces :: [(Ident,Ident)], -- non-empty for functors - minstances :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for instant'ions - mextends :: [(Ident,MInclude)], - mopens :: [(Ident,Ident)], -- used name, original name - mflags :: Map Ident String, - mjments :: MapJudgement - } - -emptyModule :: Ident -> Module -emptyModule m = Module MTGrammar True [] [] [] [] empty empty - -type MapJudgement = Map Ident JEntry -- def or indirection - -isCompleteModule :: Module -> Bool -isCompleteModule = miscomplete ---- Prelude.null . minterfaces - -isInterface :: Module -> Bool -isInterface m = case mtype m of - MTInterface -> True - MTAbstract -> True - _ -> False - -interfaceName :: Module -> Maybe Ident -interfaceName mo = case mtype mo of - MTInstance i -> return i - MTConcrete i -> return i - _ -> Nothing - -listJudgements :: Module -> [(Ident,JEntry)] -listJudgements = assocs . mjments - -type JEntry = Either Judgement Indirection - -data ModuleType = - MTAbstract - | MTConcrete Ident - | MTInterface - | MTInstance Ident - | MTGrammar - deriving Eq - -data MInclude = - MIAll - | MIExcept [Ident] - | MIOnly [Ident] - -type Indirection = (Ident,Bool) -- module of origin, whether canonical - -isConstructorEntry :: Either Judgement Indirection -> Bool -isConstructorEntry ji = case ji of - Left j -> isConstructor j - Right i -> snd i - -isConstructor :: Judgement -> Bool -isConstructor j = jdef j == EData - -isInherited :: MInclude -> Ident -> Bool -isInherited mi i = case mi of - MIExcept is -> notElem i is - MIOnly is -> elem i is - _ -> True - - diff --git a/src/GF/Devel/Grammar/PatternMatch.hs b/src/GF/Devel/Grammar/PatternMatch.hs index 193694a27..076aaa25a 100644 --- a/src/GF/Devel/Grammar/PatternMatch.hs +++ b/src/GF/Devel/Grammar/PatternMatch.hs @@ -18,7 +18,7 @@ module GF.Devel.Grammar.PatternMatch (matchPattern, ) where -import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar import GF.Devel.Grammar.Macros import GF.Devel.Grammar.PrGF import GF.Infra.Ident diff --git a/src/GF/Devel/Grammar/PrGF.hs b/src/GF/Devel/Grammar/PrGF.hs index 83ab4c7f1..09df91efc 100644 --- a/src/GF/Devel/Grammar/PrGF.hs +++ b/src/GF/Devel/Grammar/PrGF.hs @@ -21,11 +21,10 @@ module GF.Devel.Grammar.PrGF where -import qualified GF.Devel.Grammar.PrintGF as P +import qualified GF.Devel.Compile.PrintGF as P import GF.Devel.Grammar.GFtoSource -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct ----import GF.Grammar.Values ----import GF.Infra.Option @@ -68,9 +67,6 @@ prGF = cprintTree . trGrammar prModule :: SourceModule -> String prModule = cprintTree . trModule -prJEntry :: JEntry -> String -prJEntry = either prt show - instance Print Judgement where prt j = cprintTree $ trAnyDef (wildIdent, j) ---- prt_ = prExp diff --git a/src/GF/Devel/Grammar/SourceToGF.hs b/src/GF/Devel/Grammar/SourceToGF.hs deleted file mode 100644 index e09b9964c..000000000 --- a/src/GF/Devel/Grammar/SourceToGF.hs +++ /dev/null @@ -1,670 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : SourceToGF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/04 11:05:07 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.28 $ --- --- based on the skeleton Haskell module generated by the BNF converter ------------------------------------------------------------------------------ - -module GF.Devel.Grammar.SourceToGF ( - transGrammar, - transModDef, - transExp, ----- transOldGrammar, ----- transInclude, - newReservedWords - ) where - -import qualified GF.Devel.Grammar.Terms as G -----import qualified GF.Grammar.PrGrammar as GP -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.MkJudgements -import GF.Devel.Grammar.Modules -import qualified GF.Devel.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.Infra.Ident -import GF.Devel.Grammar.AbsGF -import GF.Devel.Grammar.PrintGF (printTree) -----import GF.Source.PrintGF -----import GF.Compile.RemoveLiT --- for bw compat -import GF.Data.Operations ---import GF.Infra.Option - -import Control.Monad -import Data.Char -import qualified Data.Map as Map -import Data.List (genericReplicate) - -import Debug.Trace (trace) ---- - --- based on the skeleton Haskell module generated by the BNF converter - -type Result = Err String - -failure :: Show a => a -> Err b -failure x = Bad $ "Undefined case: " ++ show x - -getIdentPos :: PIdent -> Err (Ident,Int) -getIdentPos x = case x of - PIdent ((line,_),c) -> return (IC c,line) - -transIdent :: PIdent -> Err Ident -transIdent = liftM fst . getIdentPos - -transName :: Name -> Err Ident -transName n = case n of - PIdentName i -> transIdent i - ListName i -> transIdent (mkListId i) - -transGrammar :: Grammar -> Err GF -transGrammar x = case x of - Gr moddefs -> do - moddefs' <- mapM transModDef moddefs - let mos = Map.fromList moddefs' - return $ emptyGF {gfmodules = mos} - -transModDef :: ModDef -> Err (Ident,Module) -transModDef x = case x of - MModule compl mtyp body -> do - - let isCompl = transComplMod compl - - (trDef, mtyp', id') <- case mtyp of - MAbstract id -> do - id' <- transIdent id - return (transAbsDef, MTAbstract, id') - MGrammar id -> mkModRes id MTGrammar body - MResource id -> mkModRes id MTGrammar body - MConcrete id open -> do - id' <- transIdent id - open' <- transIdent open - return (transCncDef, MTConcrete open', id') - MInterface id -> mkModRes id MTInterface body - MInstance id open -> do - open' <- transIdent open - mkModRes id (MTInstance open') body - - mkBody (isCompl, trDef, mtyp', id') body - where - mkBody xx@(isc, trDef, mtyp', id') bod = case bod of - MNoBody incls -> do - mkBody xx $ MBody (Ext incls) NoOpens [] - MBody extends opens defs -> do - extends' <- transExtend extends - opens' <- transOpens opens - defs0 <- mapM trDef $ getTopDefs defs - let defs' = Map.fromListWith unifyJudgements - [(i,Left d) | Left ds <- defs0, (i,d) <- ds] - let flags' = Map.fromList [f | Right fs <- defs0, f <- fs] - return (id', Module mtyp' isc [] [] extends' opens' flags' defs') - - MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens [] - MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs - MWithE extends m insts -> mkBody xx $ MWithEBody extends m insts NoOpens [] - MWithEBody extends m insts opens defs -> do - extends' <- mapM transIncludedExt extends - m' <- transIncludedExt m - insts' <- mapM transOpen insts - opens' <- transOpens opens - defs0 <- mapM trDef $ getTopDefs defs - let defs' = Map.fromListWith unifyJudgements - [(i,Left d) | Left ds <- defs0, (i,d) <- ds] - let flags' = Map.fromList [f | Right fs <- defs0, f <- fs] - return (id', Module mtyp' isc [] [(m',insts')] extends' opens' flags' defs') - _ -> fail "deprecated module form" - - - mkModRes id mtyp body = do - id' <- transIdent id - return (transResDef, mtyp, id') - - -getTopDefs :: [TopDef] -> [TopDef] -getTopDefs x = x - -transComplMod :: ComplMod -> Bool -transComplMod x = case x of - CMCompl -> True - CMIncompl -> False - -transExtend :: Extend -> Err [(Ident,MInclude)] -transExtend x = case x of - Ext ids -> mapM transIncludedExt ids - NoExt -> return [] - -transOpens :: Opens -> Err [(Ident,Ident)] -transOpens x = case x of - NoOpens -> return [] - OpenIn opens -> mapM transOpen opens - -transOpen :: Open -> Err (Ident,Ident) -transOpen x = case x of - OName id -> transIdent id >>= \y -> return (y,y) - OQual id m -> liftM2 (,) (transIdent id) (transIdent m) - -transIncludedExt :: Included -> Err (Ident, MInclude) -transIncludedExt x = case x of - IAll i -> liftM2 (,) (transIdent i) (return MIAll) - ISome i ids -> liftM2 (,) (transIdent i) (liftM MIOnly $ mapM transIdent ids) - IMinus i ids -> liftM2 (,) (transIdent i) (liftM MIExcept $ mapM transIdent ids) - -transAbsDef :: TopDef -> Err (Either [(Ident,Judgement)] [(Ident,String)]) -transAbsDef x = case x of - DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs - DefFun fundefs -> do - fundefs' <- mapM transFunDef fundefs - returnl [(fun, absFun typ) | (funs,typ) <- fundefs', fun <- funs] -{- ---- - DefFunData fundefs -> do - fundefs' <- mapM transFunDef fundefs - returnl $ - [(cat, G.AbsCat nope (yes [M.cn fun])) | (funs,typ) <- fundefs', - fun <- funs, - Ok (_,cat) <- [M.valCat typ] - ] ++ - [(fun, G.AbsFun (yes typ) (yes G.EData)) | (funs,typ) <- fundefs', fun <- funs] - DefDef defs -> do - defs' <- liftM concat $ mapM getDefsGen defs - returnl [(c, G.AbsFun nope pe) | (c,(_,pe)) <- defs'] - DefData ds -> do - ds' <- mapM transDataDef ds - returnl $ - [(c, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++ - [(f, G.AbsFun nope (yes G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf] --} - DefFlag defs -> liftM (Right . concat) $ mapM transFlagDef defs - _ -> return $ Left [] ---- ----- _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x - where - -- to get data constructors as terms - funs t = case t of - G.Con f -> [f] - G.Q _ f -> [f] - G.QC _ f -> [f] - _ -> [] - -returnl :: a -> Err (Either a b) -returnl = return . Left - -transFlagDef :: Def -> Err [(Ident,String)] -transFlagDef x = case x of - DDef f x -> do - fs <- mapM transName f - x' <- transExp x - v <- case x' of - G.K s -> return s - G.Vr (IC s) -> return s - G.EInt i -> return $ show i - _ -> fail $ "illegal flag value" +++ printTree x - return $ [(f',v) | f' <- fs] - - --- | Cat definitions can also return some fun defs --- if it is a list category definition -transCatDef :: CatDef -> Err [(Ident, Judgement)] -transCatDef x = case x of - SimpleCatDef id ddecls -> liftM (:[]) $ cat id ddecls - ListCatDef id ddecls -> listCat id ddecls 0 - ListSizeCatDef id ddecls size -> listCat id ddecls size - where - cat id ddecls = do - i <- transIdent id - cont <- liftM concat $ mapM transDDecl ddecls - return (i, absCat cont) - listCat id ddecls size = do - let li = mkListId id - li' <- transIdent $ li - baseId <- transIdent $ mkBaseId id - consId <- transIdent $ mkConsId id - catd0@(c,ju) <- cat li ddecls - id' <- transIdent id - let - cont0 = [] ---- cat context - catd = (c,ju) ----(Yes cont0) (Yes [M.cn baseId,M.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) - lc = M.mkApp (G.Vr li') xs - niltyp = M.mkProd (cont ++ genericReplicate size cd) lc - nilfund = (baseId, absFun niltyp) ---- (yes niltyp) (yes G.EData)) - constyp = M.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 - -transFunDef :: FunDef -> Err ([Ident], G.Type) -transFunDef x = case x of - FDecl ids typ -> liftM2 (,) (mapM transName ids) (transExp typ) - -{- ---- -transDataDef :: DataDef -> Err (Ident,[G.Term]) -transDataDef x = case x of - DataDef id ds -> liftM2 (,) (transIdent id) (mapM transData ds) - where - transData d = case d of - DataId id -> liftM G.Con $ transIdent id - DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id) --} - -transResDef :: TopDef -> Err (Either [(Ident,Judgement)] [(Ident,String)]) -transResDef x = case x of - DefPar pardefs -> do - pardefs' <- mapM transParDef pardefs - returnl $ concatMap mkParamDefs pardefs' - - DefOper defs -> do - defs' <- liftM concat $ mapM getDefs defs - returnl $ concatMap mkOverload [(f, resOper pt pe) | (f,(pt,pe)) <- defs'] - - DefLintype defs -> do - defs' <- liftM concat $ mapM getDefs defs - returnl [(f, resOper pt pe) | (f,(pt,pe)) <- defs'] - - DefFlag defs -> liftM (Right . concat) $ mapM transFlagDef defs - _ -> Bad $ "illegal definition form in resource" +++ printTree x - where - - 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.App keyw (G.RecType fs@(_:_:_)),_) | isOverloading keyw c fs -> [] - _ -> [(c,j)] - isOverloading (G.Vr keyw) c fs = - prIdent keyw == "overload" && -- overload is a "soft keyword" - True ---- all (== GP.prt c) (map (GP.prt . fst) fs) - -transParDef :: ParDef -> Err (Ident, [(Ident,G.Context)]) -transParDef x = case x of - ParDefDir id params -> liftM2 (,) (transIdent id) (mapM transParConstr params) - ParDefAbs id -> liftM2 (,) (transIdent id) (return []) - -transCncDef :: TopDef -> Err (Either [(Ident,Judgement)] [(Ident,String)]) -transCncDef x = case x of - DefLincat defs -> do - defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, cncCat t) | (f,t) <- defs'] ----- DefLindef defs -> do ----- defs' <- liftM concat $ mapM getDefs defs ----- returnl [(f, G.CncCat pt pe nope) | (f,(pt,pe)) <- defs'] - DefLin defs -> do - defs' <- liftM concat $ mapM getDefs defs - returnl [(f, cncFun pe) | (f,(_,pe)) <- defs'] -{- ---- - DefPrintCat defs -> do - defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, G.CncCat nope nope (yes e)) | (f,e) <- defs'] - DefPrintFun defs -> do - defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] - DefPrintOld defs -> do --- a guess, for backward compatibility - defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] - DefFlag defs -> liftM Right $ mapM transFlagDef defs - DefPattern defs -> do - defs' <- liftM concat $ mapM getDefs defs - let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs'] - returnl [(f, G.CncFun Nothing (yes t) nope) | (f,t) <- defs2] --} - _ -> errIn ("illegal definition in concrete syntax:") $ transResDef x - -transPrintDef :: Def -> Err [(Ident,G.Term)] -transPrintDef x = case x of - DDef ids exp -> do - (ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp) - return $ [(i,e) | i <- ids] - -getDefsGen :: Def -> Err [(Ident, (G.Type, G.Term))] -getDefsGen d = case d of - DDecl ids t -> do - ids' <- mapM transName ids - t' <- transExp t - return [(i,(t', nope)) | i <- ids'] - DDef ids e -> do - ids' <- mapM transName ids - e' <- transExp e - return [(i,(nope, yes e')) | i <- ids'] - DFull ids t e -> do - ids' <- mapM transName ids - t' <- transExp t - e' <- transExp e - return [(i,(yes t', yes e')) | i <- ids'] - DPatt id patts e -> do - id' <- transName id - ps' <- mapM transPatt patts - e' <- transExp e - return [(id',(nope, yes (G.Eqs [(ps',e')])))] - where - yes = id - nope = G.Meta 0 - --- | sometimes you need this special case, e.g. in linearization rules -getDefs :: Def -> Err [(Ident, (G.Type, G.Term))] -getDefs d = case d of - DPatt id patts e -> do - id' <- transName id - xs <- mapM tryMakeVar patts - e' <- transExp e - return [(id',(nope, (M.mkAbs xs e')))] - _ -> getDefsGen d - where - nope = G.Meta 0 - --- | accepts a pattern that is either a variable or a wild card -tryMakeVar :: Patt -> Err Ident -tryMakeVar p = do - p' <- transPatt p - case p' of - G.PV i -> return i - G.PW -> return identW - _ -> Bad $ "not a legal pattern in lambda binding" +++ show p' - -transExp :: Exp -> Err G.Term -transExp x = case x of - EPIdent id -> liftM G.Vr $ transIdent id - EConstr id -> liftM G.Con $ transIdent id - ECons id -> liftM G.Con $ transIdent id - 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 - EInt n -> return $ G.EInt n - EFloat n -> return $ G.EFloat n - EMeta -> return $ G.Meta 0 - EEmpty -> return G.Empty - -- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n) - EList i es -> transExp $ foldl EApp (EPIdent (mkListId i)) (exps2list es) - EStrings [] -> return G.Empty - EStrings str -> return $ foldr1 G.C $ map G.K $ words str - ERecord defs -> erecord2term defs - ETupTyp _ _ -> do - let tups t = case t of - ETupTyp x y -> tups x ++ [y] -- right-associative parsing - _ -> [t] - es <- mapM transExp $ tups x - return $ G.RecType $ [] ---- M.tuple2recordType es - ETuple tuplecomps -> do - es <- mapM transExp [e | TComp e <- tuplecomps] - return $ G.R $ [] ---- M.tuple2record es - EProj exp id -> liftM2 G.P (transExp exp) (trLabel id) - EApp exp0 exp -> liftM2 G.App (transExp exp0) (transExp exp) - ETable cases -> liftM (G.T G.TRaw) (transCases cases) - ETTable exp cases -> - liftM2 (\t c -> G.T (G.TTyped t) c) (transExp exp) (transCases cases) - EVTable exp cases -> - liftM2 (\t c -> G.V t c) (transExp exp) (mapM transExp cases) - ECase exp cases -> do - exp' <- transExp exp - cases' <- transCases cases - let annot = case exp' of - G.Typed _ t -> G.TTyped t - _ -> G.TRaw - return $ G.S (G.T annot cases') exp' - ECTable binds exp -> liftM2 M.mkCTable (mapM transBind binds) (transExp exp) - - EVariants exps -> liftM G.FV $ mapM transExp exps - EPre exp alts -> liftM2 (curry G.Alts) (transExp exp) (mapM transAltern alts) - EStrs exps -> liftM G.FV $ mapM transExp exps - ESelect exp0 exp -> liftM2 G.S (transExp exp0) (transExp exp) - EExtend exp0 exp -> liftM2 G.ExtR (transExp exp0) (transExp exp) - EAbstr binds exp -> liftM2 M.mkAbs (mapM transBind binds) (transExp exp) - ETyped exp0 exp -> liftM2 G.Typed (transExp exp0) (transExp exp) - EExample exp str -> liftM2 G.Example (transExp exp) (return str) - - EProd decl exp -> liftM2 M.mkProd (transDecl decl) (transExp exp) - ETType exp0 exp -> liftM2 G.Table (transExp exp0) (transExp exp) - EConcat exp0 exp -> liftM2 G.C (transExp exp0) (transExp exp) - EGlue exp0 exp -> liftM2 G.Glue (transExp exp0) (transExp exp) - ELet defs exp -> do - exp' <- transExp exp - defs0 <- mapM locdef2fields defs - defs' <- mapM tryLoc $ concat defs0 - return $ M.mkLet defs' exp' - where - tryLoc (c,(mty,Just e)) = return (c,(mty,e)) - tryLoc (c,_) = Bad $ "local definition of" +++ prIdent c +++ "without value" - ELetb defs exp -> transExp $ ELet defs exp - EWhere exp defs -> transExp $ ELet defs exp - - ELString (LString str) -> return $ G.K str ----- ELin id -> liftM G.LiT $ transIdent id - - EEqs eqs -> liftM G.Eqs $ mapM transEquation eqs - - _ -> Bad $ "translation not yet defined for" +++ printTree x ---- - -exps2list :: Exps -> [Exp] -exps2list NilExp = [] -exps2list (ConsExp e es) = e : exps2list es - ---- this is complicated: should we change Exp or G.Term ? - -erecord2term :: [LocDef] -> Err G.Term -erecord2term ds = do - ds' <- mapM locdef2fields ds - mkR $ concat ds' - where - mkR fs = do - fs' <- transF fs - return $ case fs' of - Left ts -> G.RecType ts - Right ds -> G.R ds - transF [] = return $ Left [] --- empty record always interpreted as record type - transF fs@(f:_) = case f of - (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) - _ -> Bad $ "illegal record type field" +++ show (fst f) --- manifest fields ?! - tryR f = case f of - (lab,(mty, Just t)) -> return (M.ident2label lab,(mty,t)) - _ -> Bad $ "illegal record field" +++ show (fst f) - - -locdef2fields :: LocDef -> Err [(Ident, (Maybe G.Type, Maybe G.Type))] -locdef2fields d = case d of - LDDecl ids t -> do - labs <- mapM transIdent ids - t' <- transExp t - return [(lab,(Just t',Nothing)) | lab <- labs] - LDDef ids e -> do - labs <- mapM transIdent ids - e' <- transExp e - return [(lab,(Nothing, Just e')) | lab <- labs] - LDFull ids t e -> do - labs <- mapM transIdent ids - t' <- transExp t - e' <- transExp e - return [(lab,(Just t', Just e')) | lab <- labs] - -trLabel :: Label -> Err G.Label -trLabel x = case x of - - -- this case is for bward compatibiity and should be removed - LPIdent (PIdent (_,'v':ds)) | all isDigit ds -> return $ G.LVar $ readIntArg ds - - LPIdent (PIdent (_, s)) -> return $ G.LIdent s - LVar x -> return $ G.LVar $ fromInteger x - -transSort :: Sort -> Err String -transSort x = case x of - _ -> return $ printTree x - -transPatt :: Patt -> Err G.Patt -transPatt x = case x of - PW -> return G.wildPatt - PV id -> liftM G.PV $ transIdent id - PC id patts -> liftM2 G.PC (transIdent id) (mapM transPatt patts) - PCon id -> liftM2 G.PC (transIdent id) (return []) - PInt n -> return $ G.PInt n - PFloat n -> return $ G.PFloat n - PStr str -> return $ G.PString str - PR pattasss -> do - let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss] - ls = map LPIdent $ concat lss - liftM G.PR $ liftM2 zip (mapM trLabel ls) (mapM transPatt ps) - PTup pcs -> - liftM (G.PR . M.tuple2recordPatt) (mapM transPatt [e | PTComp e <- pcs]) - PQ id0 id -> liftM3 G.PP (transIdent id0) (transIdent id) (return []) - PQC id0 id patts -> - liftM3 G.PP (transIdent id0) (transIdent id) (mapM transPatt patts) - PDisj p1 p2 -> liftM2 G.PAlt (transPatt p1) (transPatt p2) - PSeq p1 p2 -> liftM2 G.PSeq (transPatt p1) (transPatt p2) - PRep p -> liftM G.PRep (transPatt p) - PNeg p -> liftM G.PNeg (transPatt p) - PAs x p -> liftM2 G.PAs (transIdent x) (transPatt p) - - - -transBind :: Bind -> Err Ident -transBind x = case x of - BPIdent id -> transIdent id - BWild -> return identW - -transDecl :: Decl -> Err [G.Decl] -transDecl x = case x of - DDec binds exp -> do - xs <- mapM transBind binds - exp' <- transExp exp - return [(x,exp') | x <- xs] - DExp exp -> liftM (return . M.mkDecl) $ transExp exp - -transCases :: [Case] -> Err [G.Case] -transCases = mapM transCase - -transCase :: Case -> Err G.Case -transCase (Case p exp) = do - patt <- transPatt p - exp' <- transExp exp - return (patt,exp') - -transEquation :: Equation -> Err G.Equation -transEquation x = case x of - Equ apatts exp -> liftM2 (,) (mapM transPatt apatts) (transExp exp) - -transAltern :: Altern -> Err (G.Term, G.Term) -transAltern x = case x of - Alt exp0 exp -> liftM2 (,) (transExp exp0) (transExp exp) - -transParConstr :: ParConstr -> Err (Ident,G.Context) -transParConstr x = case x of - ParConstr id ddecls -> do - id' <- transIdent id - ddecls' <- mapM transDDecl ddecls - return (id',concat ddecls') - -transDDecl :: DDecl -> Err [G.Decl] -transDDecl x = case x of - DDDec binds exp -> transDecl $ DDec binds exp - DDExp exp -> transDecl $ DExp exp - -{- ---- --- | to deal with the old format, sort judgements in three modules, forming --- their names from a given string, e.g. file name or overriding user-given string -transOldGrammar :: Options -> FilePath -> OldGrammar -> Err G.SourceGrammar -transOldGrammar opts name0 x = case x of - OldGr includes topdefs -> do --- includes must be collected separately - let moddefs = sortTopDefs topdefs - g1 <- transGrammar $ Gr moddefs - removeLiT g1 --- needed for bw compatibility with an obsolete feature - where - sortTopDefs ds = [mkAbs a,mkRes ops r,mkCnc ops c] ++ map mkPack ps - where - ops = map fst ps - (a,r,c,ps) = foldr srt ([],[],[],[]) ds - srt d (a,r,c,ps) = case d of - DefCat catdefs -> (d:a,r,c,ps) - DefFun fundefs -> (d:a,r,c,ps) - DefFunData fundefs -> (d:a,r,c,ps) - DefDef defs -> (d:a,r,c,ps) - DefData pardefs -> (d:a,r,c,ps) - DefPar pardefs -> (a,d:r,c,ps) - DefOper defs -> (a,d:r,c,ps) - DefLintype defs -> (a,d:r,c,ps) - DefLincat defs -> (a,r,d:c,ps) - DefLindef defs -> (a,r,d:c,ps) - DefLin defs -> (a,r,d:c,ps) - DefPattern defs -> (a,r,d:c,ps) - DefFlag defs -> (a,r,d:c,ps) --- a guess - DefPrintCat printdefs -> (a,r,d:c,ps) - DefPrintFun printdefs -> (a,r,d:c,ps) - DefPrintOld printdefs -> (a,r,d:c,ps) - DefPackage m ds -> (a,r,c,(m,ds):ps) - _ -> (a,r,c,ps) - mkAbs a = MModule q (MTAbstract absName) (MBody ne (OpenIn []) (topDefs a)) - mkRes ps r = MModule q (MTResource resName) (MBody ne (OpenIn ops) (topDefs r)) - where ops = map OName ps - mkCnc ps r = MModule q (MTConcrete cncName absName) - (MBody ne (OpenIn (map OName (resName:ps))) (topDefs r)) - mkPack (m, ds) = MModule q (MTResource m) (MBody ne (OpenIn []) (topDefs ds)) - topDefs t = t - ne = NoExt - q = CMCompl - - name = maybe name0 (++ ".gf") $ getOptVal opts useName - absName = identC $ maybe topic id $ getOptVal opts useAbsName - resName = identC $ maybe ("Res" ++ lang) id $ getOptVal opts useResName - cncName = identC $ maybe lang id $ getOptVal opts useCncName - - (beg,rest) = span (/='.') name - (topic,lang) = case rest of -- to avoid overwriting old files - ".gf" -> ("Abs" ++ beg,"Cnc" ++ beg) - ".cf" -> ("Abs" ++ beg,"Cnc" ++ beg) - ".ebnf" -> ("Abs" ++ beg,"Cnc" ++ beg) - [] -> ("Abs" ++ beg,"Cnc" ++ beg) - _:s -> (beg, takeWhile (/='.') s) - -transInclude :: Include -> Err [FilePath] -transInclude x = case x of - NoIncl -> return [] - Incl filenames -> return $ map trans filenames - where - trans f = case f of - FString s -> s - FIdent (IC s) -> modif s - FSlash filename -> '/' : trans filename - FDot filename -> '.' : trans filename - FMinus filename -> '-' : trans filename - FAddId (IC s) filename -> modif s ++ trans filename - modif s = let s' = init s ++ [toLower (last s)] in - if elem s' newReservedWords then s' else s - --- unsafe hack ; cf. GetGrammar.oldLexer --} - -newReservedWords :: [String] -newReservedWords = - words $ "abstract concrete interface incomplete " ++ - "instance out open resource reuse transfer union with where" - -termInPattern :: G.Term -> G.Term -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" - (xx,body) = abss [] t - abss xs t = case t of - G.Abs x b -> abss (x:xs) b - _ -> (reverse xs,t) - -mkListId,mkConsId,mkBaseId :: PIdent -> PIdent -mkListId = prefixId "List" -mkConsId = prefixId "Cons" -mkBaseId = prefixId "Base" - -prefixId :: String -> PIdent -> PIdent -prefixId pref (PIdent (p,id)) = PIdent (p, pref ++ id) diff --git a/src/GF/Devel/Grammar/Terms.hs b/src/GF/Devel/Grammar/Terms.hs deleted file mode 100644 index d57e7c160..000000000 --- a/src/GF/Devel/Grammar/Terms.hs +++ /dev/null @@ -1,118 +0,0 @@ -module GF.Devel.Grammar.Terms where - -import GF.Infra.Ident - -import GF.Data.Operations - -type Type = Term -type Cat = QIdent -type Fun = QIdent - -type QIdent = (Ident,Ident) - -data Term = - Vr Ident -- ^ variable - | Con Ident -- ^ constructor - | EData -- ^ to mark in definition that a fun is a constructor - | Sort String -- ^ predefined type - | EInt Integer -- ^ integer literal - | EFloat Double -- ^ floating point literal - | K String -- ^ string literal or token: @\"foo\"@ - | Empty -- ^ the empty string @[]@ - - | App Term Term -- ^ application: @f a@ - | Abs Ident Term -- ^ abstraction: @\x -> b@ - | Meta MetaSymb -- ^ metavariable: @?i@ (only parsable: ? = ?0) - | Prod Ident Term Term -- ^ function type: @(x : A) -> B@ - | Eqs [Equation] -- ^ abstraction by cases: @fn {x y -> b ; z u -> c}@ - -- only used in internal representation - | Typed Term Term -- ^ type-annotated term --- --- /below this, the constructors are only for concrete syntax/ - | Example Term String -- ^ example-based term: @in M.C "foo" - | RecType [Labelling] -- ^ record type: @{ p : A ; ...}@ - | R [Assign] -- ^ record: @{ p = a ; ...}@ - | P Term Label -- ^ projection: @r.p@ - | PI Term Label Int -- ^ index-annotated projection - | ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms) - - | Table Term Term -- ^ table type: @P => A@ - | T TInfo [Case] -- ^ table: @table {p => c ; ...}@ - | V Type [Term] -- ^ course of values: @table T [c1 ; ... ; cn]@ - | S Term Term -- ^ selection: @t ! p@ - | Val Type Int -- ^ parameter value number: @T # i# - - | Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@ - - | Q Ident Ident -- ^ qualified constant from a module - | QC Ident Ident -- ^ qualified constructor from a module - - | C Term Term -- ^ concatenation: @s ++ t@ - | Glue Term Term -- ^ agglutination: @s + t@ - - | FV [Term] -- ^ free variation: @variants { s ; ... }@ - - | Alts (Term, [(Term, Term)]) -- ^ prefix-dependent: @pre {t ; s\/c ; ...}@ - - | Overload [(Type,Term)] - - deriving (Read, Show, Eq, Ord) - -data Patt = - PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@ - | PP Ident Ident [Patt] -- ^ qualified constr patt: @P.C p1 ... pn@ @P.C@ - | PV Ident -- ^ variable pattern: @x@ - | PW -- ^ wild card pattern: @_@ - | PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ - | PString String -- ^ string literal pattern: @\"foo\"@ - | PInt Integer -- ^ integer literal pattern: @12@ - | PFloat Double -- ^ float literal pattern: @1.2@ - | PT Type Patt -- ^ type-annotated pattern - | PAs Ident Patt -- ^ as-pattern: x@p - - -- regular expression patterns - | PNeg Patt -- ^ negated pattern: -p - | PAlt Patt Patt -- ^ disjunctive pattern: p1 | p2 - | PSeq Patt Patt -- ^ sequence of token parts: p + q - | PRep Patt -- ^ repetition of token part: p* - - deriving (Read, Show, Eq, Ord) - --- | to guide computation and type checking of tables -data TInfo = - TRaw -- ^ received from parser; can be anything - | TTyped Type -- ^ type annotated, but can be anything - | TComp Type -- ^ expanded - | TWild Type -- ^ just one wild card pattern, no need to expand - deriving (Read, Show, Eq, Ord) - --- | record label -data Label = - LIdent String - | LVar Int - deriving (Read, Show, Eq, Ord) - -type MetaSymb = Int - -type Decl = (Ident,Term) -- (x:A) (_:A) A -type Context = [Decl] -- (x:A)(y:B) (x,y:A) (_,_:A) -type Substitution = [(Ident, Term)] -type Equation = ([Patt],Term) - -type Labelling = (Label, Term) -type Assign = (Label, (Maybe Type, Term)) -type Case = (Patt, Term) -type LocalDef = (Ident, (Maybe Type, Term)) - - --- | branches à la Alfa -newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read) -type Con = Ident --- - -varLabel :: Int -> Label -varLabel = LVar - -wildPatt :: Patt -wildPatt = PW - -type Trm = Term -- cgit v1.2.3