From 60bd12a952dae70e23f8f79077ce41dd86043d34 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Thu, 7 Sep 2017 14:01:46 +0200 Subject: [PATCH] the experimental export to Lambda Prolog is now obsolete and is removed --- gf.cabal | 1 - src/compiler/GF/Compile/Export.hs | 2 - src/compiler/GF/Compile/PGFtoLProlog.hs | 164 ------------------------ src/compiler/GF/Compiler.hs | 5 +- src/compiler/GF/Infra/Option.hs | 4 - 5 files changed, 2 insertions(+), 174 deletions(-) delete mode 100644 src/compiler/GF/Compile/PGFtoLProlog.hs diff --git a/gf.cabal b/gf.cabal index c9f02c324..86c94f32f 100644 --- a/gf.cabal +++ b/gf.cabal @@ -196,7 +196,6 @@ Library GF.Haskell GF.Compile.ConcreteToHaskell GF.Compile.PGFtoJS - GF.Compile.PGFtoLProlog GF.Compile.PGFtoProlog GF.Compile.PGFtoPython GF.Compile.ReadFiles diff --git a/src/compiler/GF/Compile/Export.hs b/src/compiler/GF/Compile/Export.hs index b8b8ed1ac..d844e300a 100644 --- a/src/compiler/GF/Compile/Export.hs +++ b/src/compiler/GF/Compile/Export.hs @@ -5,7 +5,6 @@ import PGF.Internal(ppPGF) import GF.Compile.PGFtoHaskell import GF.Compile.PGFtoJava import GF.Compile.PGFtoProlog -import GF.Compile.PGFtoLProlog import GF.Compile.PGFtoJS import GF.Compile.PGFtoPython import GF.Infra.Option @@ -40,7 +39,6 @@ exportPGF opts fmt pgf = FmtHaskell -> multi "hs" (grammar2haskell opts name) FmtJava -> multi "java" (grammar2java opts name) FmtProlog -> multi "pl" grammar2prolog - FmtLambdaProlog -> multi "mod" grammar2lambdaprolog_mod ++ multi "sig" grammar2lambdaprolog_sig FmtBNF -> single "bnf" bnfPrinter FmtEBNF -> single "ebnf" (ebnfPrinter opts) FmtSRGS_XML -> single "grxml" (srgsXmlPrinter opts) diff --git a/src/compiler/GF/Compile/PGFtoLProlog.hs b/src/compiler/GF/Compile/PGFtoLProlog.hs deleted file mode 100644 index 28ee6afaf..000000000 --- a/src/compiler/GF/Compile/PGFtoLProlog.hs +++ /dev/null @@ -1,164 +0,0 @@ -module GF.Compile.PGFtoLProlog(grammar2lambdaprolog_mod, grammar2lambdaprolog_sig) where - -import PGF(mkCId,ppCId,showCId,wildCId) -import PGF.Internal hiding (ppExpr,ppType,ppHypo,ppCat,ppFun) ---import PGF.Macros -import Data.List -import Data.Maybe -import GF.Text.Pretty -import qualified Data.Map as Map ---import Debug.Trace - -grammar2lambdaprolog_mod pgf = render $ - "module" <+> ppCId (absname pgf) <> '.' $$ - ' ' $$ - vcat [ppClauses cat fns | (cat,(_,fs,_)) <- Map.toList (cats (abstract pgf)), - let fns = [(f,fromJust (Map.lookup f (funs (abstract pgf)))) | (_,f) <- fs]] - where - ppClauses cat fns = - "/*" <+> ppCId cat <+> "*/" $$ - vcat [snd (ppClause (abstract pgf) 0 1 [] f ty) <> dot | (f,(ty,_,Nothing,_)) <- fns] $$ - ' ' $$ - vcat [vcat (map (\eq -> equation2clause (abstract pgf) f eq <> dot) eqs) | (f,(_,_,Just (eqs,_),_)) <- fns] $$ - ' ' - -grammar2lambdaprolog_sig pgf = render $ - "sig" <+> ppCId (absname pgf) <> '.' $$ - ' ' $$ - vcat [ppCat c hyps <> dot | (c,(hyps,_,_)) <- Map.toList (cats (abstract pgf))] $$ - ' ' $$ - vcat [ppFun f ty <> dot | (f,(ty,_,Nothing,_)) <- Map.toList (funs (abstract pgf))] $$ - ' ' $$ - vcat [ppExport c hyps <> dot | (c,(hyps,_,_)) <- Map.toList (cats (abstract pgf))] $$ - vcat [ppFunPred f (hyps ++ [(Explicit,wildCId,DTyp [] c es)]) <> dot | (f,(DTyp hyps c es,_,Just _,_)) <- Map.toList (funs (abstract pgf))] - -ppCat :: CId -> [Hypo] -> Doc -ppCat c hyps = "kind" <+> ppKind c <+> "type" - -ppFun :: CId -> Type -> Doc -ppFun f ty = "type" <+> ppCId f <+> ppType 0 ty - -ppExport :: CId -> [Hypo] -> Doc -ppExport c hyps = "exportdef" <+> ppPred c <+> foldr (\hyp doc -> ppHypo 1 hyp <+> "->" <+> doc) (pp "o") (hyp:hyps) - where - hyp = (Explicit,wildCId,DTyp [] c []) - -ppFunPred :: CId -> [Hypo] -> Doc -ppFunPred c hyps = "exportdef" <+> ppCId c <+> foldr (\hyp doc -> ppHypo 1 hyp <+> "->" <+> doc) (pp "o") hyps - -ppClause :: Abstr -> Int -> Int -> [CId] -> CId -> Type -> (Int,Doc) -ppClause abstr d i scope f ty@(DTyp hyps cat args) - | null hyps = let res = EFun f - (goals,i',head) = ppRes i scope cat (res : args) - in (i',(if null goals - then empty - else hsep (punctuate ',' (map (ppExpr 0 i' scope) goals)) <> ',') - <+> - head) - | otherwise = let (i',vars,scope',hdocs) = ppHypos i [] scope hyps (depType [] ty) - res = foldl EApp (EFun f) (map EFun (reverse vars)) - quants = if d > 0 - then hsep (map (\v -> "pi" <+> ppCId v <+> '\\') vars) - else empty - (goals,i'',head) = ppRes i' scope' cat (res : args) - docs = map (ppExpr 0 i'' scope') goals ++ hdocs - in (i'',ppParens (d > 0) (quants <+> head <+> - (if null docs - then empty - else ":-" <+> hsep (punctuate ',' docs)))) - where - ppRes i scope cat es = - let ((goals,i'),es') = mapAccumL (\(goals,i) e -> let (goals',i',e') = expr2goal abstr scope goals i e [] - in ((goals',i'),e')) ([],i) es - in (goals,i',ppParens (d > 3) (ppPred cat <+> hsep (map (ppExpr 4 i' scope) es'))) - - ppHypos :: Int -> [CId] -> [CId] -> [(BindType,CId,Type)] -> [Int] -> (Int,[CId],[CId],[Doc]) - ppHypos i vars scope [] [] - = (i,vars,scope,[]) - ppHypos i vars scope ((_,x,typ):hyps) (c:cs) - | x /= wildCId = let v = mkVar i - (i',doc) = ppClause abstr 1 (i+1) scope v typ - (i'',vars',scope',docs) = ppHypos i' (v:vars) (v:scope) hyps cs - in (i'',vars',scope',if c == 0 then doc : docs else docs) - ppHypos i vars scope ((_,x,typ):hyps) cs - = let v = mkVar i - (i',doc) = ppClause abstr 1 (i+1) scope v typ - (i'',vars',scope',docs) = ppHypos i' (v:vars) scope hyps cs - in (i'',vars',scope',doc : docs) - -mkVar i = mkCId ("X_"++show i) - -ppPred :: CId -> Doc -ppPred cat = "p_" <> ppCId cat - -ppKind :: CId -> Doc -ppKind cat = "k_" <> ppCId cat - -ppType :: Int -> Type -> Doc -ppType d (DTyp hyps cat args) - | null hyps = ppKind cat - | otherwise = ppParens (d > 0) (foldr (\hyp doc -> ppHypo 1 hyp <+> "->" <+> doc) (ppKind cat) hyps) - -ppHypo d (_,_,typ) = ppType d typ - -ppExpr d i scope (EAbs b x e) = let v = mkVar i - in ppParens (d > 1) (ppCId v <+> '\\' <+> ppExpr 1 (i+1) (v:scope) e) -ppExpr d i scope (EApp e1 e2) = ppParens (d > 3) ((ppExpr 3 i scope e1) <+> (ppExpr 4 i scope e2)) -ppExpr d i scope (ELit l) = ppLit l -ppExpr d i scope (EMeta n) = ppMeta n -ppExpr d i scope (EFun f) = ppCId f -ppExpr d i scope (EVar j) = ppCId (scope !! j) -ppExpr d i scope (ETyped e ty)= ppExpr d i scope e -ppExpr d i scope (EImplArg e) = ppExpr 0 i scope e - -dot = '.' - -depType counts (DTyp hyps cat es) = - foldl' depExpr (foldl' depHypo counts hyps) es - -depHypo counts (_,x,ty) - | x == wildCId = depType counts ty - | otherwise = 0:depType counts ty - -depExpr counts (EAbs b x e) = tail (depExpr (0:counts) e) -depExpr counts (EApp e1 e2) = depExpr (depExpr counts e1) e2 -depExpr counts (ELit l) = counts -depExpr counts (EMeta n) = counts -depExpr counts (EFun f) = counts -depExpr counts (EVar j) = let (xs,c:ys) = splitAt j counts - in xs++(c+1):ys -depExpr counts (ETyped e ty)= depExpr counts e -depExpr counts (EImplArg e) = depExpr counts e - -equation2clause abstr f (Equ ps e) = - let scope0 = foldl pattScope [] ps - scope = [mkVar i | i <- [0..n-1]] - n = length scope0 - - es = map (patt2expr scope0) ps - - (goals,_,goal) = expr2goal abstr scope [] n e [] - - in ppCId f <+> hsep (map (ppExpr 4 n scope) (es++[goal])) <+> - if null goals - then empty - else ":-" <+> hsep (punctuate ',' (map (ppExpr 0 n scope) (reverse goals))) - - -patt2expr scope (PApp f ps) = foldl EApp (EFun f) (map (patt2expr scope) ps) -patt2expr scope (PLit l) = ELit l -patt2expr scope (PVar x) = case findIndex (==x) scope of - Just i -> EVar i - Nothing -> error ("unknown variable "++showCId x) -patt2expr scope (PImplArg p)= EImplArg (patt2expr scope p) - -expr2goal abstr scope goals i (EApp e1 e2) args = - let (goals',i',e2') = expr2goal abstr scope goals i e2 [] - in expr2goal abstr scope goals' i' e1 (e2':args) -expr2goal abstr scope goals i (EFun f) args = - case Map.lookup f (funs abstr) of - Just (_,_,Just _,_) -> let e = EFun (mkVar i) - in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e) - _ -> (goals,i,foldl EApp (EFun f) args) -expr2goal abstr scope goals i (EVar j) args = - (goals,i,foldl EApp (EVar j) args) diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs index 7fbaed9e4..aa7b80268 100644 --- a/src/compiler/GF/Compiler.hs +++ b/src/compiler/GF/Compiler.hs @@ -56,7 +56,7 @@ compileSourceFiles opts fs = return (t,[cnc_gr]) cncs2haskell output = - when (FmtHaskell `elem` outputFormats opts && + when (FmtHaskell `elem` flag optOutputFormats opts && haskellOption opts HaskellConcrete) $ mapM_ cnc2haskell (snd output) @@ -130,7 +130,7 @@ unionPGFFiles opts fs = writeOutputs :: Options -> PGF -> IOE () writeOutputs opts pgf = do sequence_ [writeOutput opts name str - | fmt <- outputFormats opts, + | fmt <- flag optOutputFormats opts, (name,str) <- exportPGF opts fmt pgf] -- | Write the result of compiling a grammar (e.g. with 'compileToPGF' or @@ -163,7 +163,6 @@ grammarName :: Options -> PGF -> String grammarName opts pgf = grammarName' opts (showCId (abstractName pgf)) grammarName' opts abs = fromMaybe abs (flag optName opts) -outputFormats opts = [fmt | fmt <- flag optOutputFormats opts, fmt/=FmtByteCode] outputJustPGF opts = null (flag optOutputFormats opts) && not (flag optSplitPGF opts) outputPath opts file = maybe id () (flag optOutputDir opts) file diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index efd59ca0b..f68c7d121 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -92,8 +92,6 @@ data OutputFormat = FmtPGFPretty | FmtHaskell | FmtJava | FmtProlog - | FmtLambdaProlog - | FmtByteCode | FmtBNF | FmtEBNF | FmtRegular @@ -478,8 +476,6 @@ outputFormatsExpl = (("haskell", FmtHaskell),"Haskell (abstract syntax)"), (("java", FmtJava),"Java (abstract syntax)"), (("prolog", FmtProlog),"Prolog (whole grammar)"), - (("lambda_prolog",FmtLambdaProlog),"LambdaProlog (abstract syntax)"), - (("lp_byte_code", FmtByteCode),"Bytecode for Teyjus (abstract syntax, experimental)"), (("bnf", FmtBNF),"BNF (context-free grammar)"), (("ebnf", FmtEBNF),"Extended BNF"), (("regular", FmtRegular),"* regular grammar"),