From faa638d6fc5dbc47d5e3ef3d4da42449005c3a0d Mon Sep 17 00:00:00 2001 From: krasimir Date: Mon, 14 Dec 2009 10:10:58 +0000 Subject: rename some modules that had GFCC in the name to PGF+something --- src/compiler/GF/Compile.hs | 4 +- src/compiler/GF/Compile/Export.hs | 6 +- src/compiler/GF/Compile/GFCCtoHaskell.hs | 230 ------------ src/compiler/GF/Compile/GFCCtoJS.hs | 122 ------- src/compiler/GF/Compile/GFCCtoProlog.hs | 279 --------------- src/compiler/GF/Compile/GrammarToGFCC.hs | 587 ------------------------------- src/compiler/GF/Compile/GrammarToPGF.hs | 587 +++++++++++++++++++++++++++++++ src/compiler/GF/Compile/OptimizeGFCC.hs | 121 ------- src/compiler/GF/Compile/OptimizePGF.hs | 121 +++++++ src/compiler/GF/Compile/PGFtoHaskell.hs | 230 ++++++++++++ src/compiler/GF/Compile/PGFtoJS.hs | 122 +++++++ src/compiler/GF/Compile/PGFtoProlog.hs | 279 +++++++++++++++ 12 files changed, 1344 insertions(+), 1344 deletions(-) delete mode 100644 src/compiler/GF/Compile/GFCCtoHaskell.hs delete mode 100644 src/compiler/GF/Compile/GFCCtoJS.hs delete mode 100644 src/compiler/GF/Compile/GFCCtoProlog.hs delete mode 100644 src/compiler/GF/Compile/GrammarToGFCC.hs create mode 100644 src/compiler/GF/Compile/GrammarToPGF.hs delete mode 100644 src/compiler/GF/Compile/OptimizeGFCC.hs create mode 100644 src/compiler/GF/Compile/OptimizePGF.hs create mode 100644 src/compiler/GF/Compile/PGFtoHaskell.hs create mode 100644 src/compiler/GF/Compile/PGFtoJS.hs create mode 100644 src/compiler/GF/Compile/PGFtoProlog.hs (limited to 'src') diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index e0c60178e..cef7b235a 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -6,8 +6,8 @@ import GF.Compile.Rename import GF.Compile.CheckGrammar import GF.Compile.Optimize import GF.Compile.SubExOpt -import GF.Compile.OptimizeGFCC -import GF.Compile.GrammarToGFCC +import GF.Compile.OptimizePGF +import GF.Compile.GrammarToPGF import GF.Compile.ReadFiles import GF.Compile.Update import GF.Compile.Refresh diff --git a/src/compiler/GF/Compile/Export.hs b/src/compiler/GF/Compile/Export.hs index d03eb947e..29f35e32a 100644 --- a/src/compiler/GF/Compile/Export.hs +++ b/src/compiler/GF/Compile/Export.hs @@ -2,9 +2,9 @@ module GF.Compile.Export where import PGF.CId import PGF.Data (PGF(..)) -import GF.Compile.GFCCtoHaskell -import GF.Compile.GFCCtoProlog -import GF.Compile.GFCCtoJS +import GF.Compile.PGFtoHaskell +import GF.Compile.PGFtoProlog +import GF.Compile.PGFtoJS import GF.Compile.PGFPretty import GF.Infra.Option import GF.Speech.CFG diff --git a/src/compiler/GF/Compile/GFCCtoHaskell.hs b/src/compiler/GF/Compile/GFCCtoHaskell.hs deleted file mode 100644 index d44d6705c..000000000 --- a/src/compiler/GF/Compile/GFCCtoHaskell.hs +++ /dev/null @@ -1,230 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GFCCtoHaskell --- Maintainer : Aarne Ranta --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/17 12:39:07 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- to write a GF abstract grammar into a Haskell module with translations from --- data objects into GF trees. Example: GSyntax for Agda. --- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004 ------------------------------------------------------------------------------ - -module GF.Compile.GFCCtoHaskell (grammar2haskell) where - -import PGF.CId -import PGF.Data -import PGF.Macros - -import GF.Data.Operations -import GF.Infra.Option -import GF.Text.UTF8 - -import Data.List --(isPrefixOf, find, intersperse) -import qualified Data.Map as Map - -type Prefix = String -> String - --- | the main function -grammar2haskell :: Options - -> String -- ^ Module name. - -> PGF - -> String -grammar2haskell opts name gr = encodeUTF8 $ foldr (++++) [] $ - pragmas ++ haskPreamble name ++ [types, gfinstances gId lexical gr'] - where gr' = hSkeleton gr - gadt = haskellOption opts HaskellGADT - lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat - gId | haskellOption opts HaskellNoPrefix = id - | otherwise = ("G"++) - pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}"] - | otherwise = [] - types | gadt = datatypesGADT gId lexical gr' - | otherwise = datatypes gId lexical gr' - -haskPreamble name = - [ - "module " ++ name ++ " where", - "", - "import PGF", - "----------------------------------------------------", - "-- automatic translation from GF to Haskell", - "----------------------------------------------------", - "", - "class Gf a where", - " gf :: a -> Tree", - " fg :: Tree -> a", - "", - predefInst "GString" "String" "unStr" "mkStr", - "", - predefInst "GInt" "Integer" "unInt" "mkInt", - "", - predefInst "GFloat" "Double" "unDouble" "mkDouble", - "", - "----------------------------------------------------", - "-- below this line machine-generated", - "----------------------------------------------------", - "" - ] - -predefInst gtyp typ destr consr = - "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++ - "instance Gf" +++ gtyp +++ "where" ++++ - " gf (" ++ gtyp +++ "x) =" +++ consr +++ "x" ++++ - " fg t =" ++++ - " case "++destr++" t of" ++++ - " Just x -> " +++ gtyp +++ "x" ++++ - " Nothing -> error (\"no" +++ gtyp +++ "\" ++ show t)" - -type OIdent = String - -type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] - -datatypes :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String -datatypes gId lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId lexical)) . snd - -gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String -gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g - - -hDatatype :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String -hDatatype _ _ ("Cn",_) = "" --- -hDatatype _ _ (cat,[]) = "" -hDatatype gId _ (cat,rules) | isListCat (cat,rules) = - "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" - +++ "deriving Show" -hDatatype gId lexical (cat,rules) = - "data" +++ gId cat +++ "=" ++ - (if length rules == 1 then "" else "\n ") +++ - foldr1 (\x y -> x ++ "\n |" +++ y) constructors ++++ - " deriving Show" - where - constructors = [gId f +++ foldr (+++) "" (map (gId) xx) | (f,xx) <- nonLexicalRules (lexical cat) rules] - ++ if lexical cat then [lexicalConstructor cat +++ "String"] else [] - -nonLexicalRules :: Bool -> [(OIdent, [OIdent])] -> [(OIdent, [OIdent])] -nonLexicalRules False rules = rules -nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)] - -lexicalConstructor :: OIdent -> String -lexicalConstructor cat = "Lex" ++ cat - --- GADT version of data types -datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String -datatypesGADT gId lexical (_,skel) = - unlines (concatMap (hCatTypeGADT gId) skel) - +++++ - "data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT gId lexical) skel) - -hCatTypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String] -hCatTypeGADT gId (cat,rules) - = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_", - "data"+++gId cat++"_"] - -hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String] -hDatatypeGADT gId lexical (cat, rules) - | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t] - | otherwise = - [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t - | (f,args) <- nonLexicalRules (lexical cat) rules ] - ++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else [] - where t = "Tree" +++ gId cat ++ "_" - -gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String -gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs - -----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004 -hInstance _ _ m (cat,[]) = "" -hInstance gId lexical m (cat,rules) - | isListCat (cat,rules) = - "instance Gf" +++ gId cat +++ "where" ++++ - " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" - +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++ - " gf (" ++ gId cat +++ "(x:xs)) = " - ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] --- no show for GADTs --- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" - | otherwise = - "instance Gf" +++ gId cat +++ "where\n" ++ - unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] - ++ if lexical cat then [" gf (" ++ lexicalConstructor cat +++ "x) = mkApp (mkCId x) []"] else []) - where - ec = elemCat cat - baseVars = mkVars (baseSize (cat,rules)) - mkInst f xx = let xx' = mkVars (length xx) in " gf " ++ - (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++ - "=" +++ mkRHS f xx' - mkVars n = ["x" ++ show i | i <- [1..n]] - mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++ - "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" - - -----fInstance m ("Cn",_) = "" --- -fInstance _ _ m (cat,[]) = "" -fInstance gId lexical m (cat,rules) = - " fg t =" ++++ - " case unApp t of" ++++ - unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++ - (if lexical cat then " (i,[]) -> " ++ lexicalConstructor cat +++ "(prCId i)" else "") ++++ - " _ -> error (\"no" +++ cat ++ " \" ++ show t)" - where - mkInst f xx = - " Just (i," ++ - "[" ++ prTList "," xx' ++ "])" +++ - "| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx' - where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]] - mkRHS f vars - | isListCat (cat,rules) = - if "Base" `isPrefixOf` f then - gId cat +++ "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]" - else - let (i,t) = (init vars,last vars) - in "let" +++ gId cat +++ "xs = fg " ++ t +++ "in" +++ - gId cat +++ prParenth (prTList ":" (["fg"+++v | v <- i] ++ ["xs"])) - | otherwise = - gId f +++ - prTList " " [prParenth ("fg" +++ x) | x <- vars] - - ---type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] -hSkeleton :: PGF -> (String,HSkeleton) -hSkeleton gr = - (showCId (absname gr), - [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) | - fs@((_, (_,c)):_) <- fns] - ) - where - fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr))))) - valtyps (_, (_,x)) (_, (_,y)) = compare x y - valtypg (_, (_,x)) (_, (_,y)) = x == y - jty (f,(ty,_,_)) = (f,catSkeleton ty) - -updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton -updateSkeleton cat skel rule = - case skel of - (cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr - (cat0,rules):rr -> (cat0, rules) : updateSkeleton cat rr rule - -isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool -isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2 - && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs - where c = elemCat cat - fs = map fst rules - --- | Gets the element category of a list category. -elemCat :: OIdent -> OIdent -elemCat = drop 4 - -isBaseFun :: OIdent -> Bool -isBaseFun f = "Base" `isPrefixOf` f - -isConsFun :: OIdent -> Bool -isConsFun f = "Cons" `isPrefixOf` f - -baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int -baseSize (_,rules) = length bs - where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules diff --git a/src/compiler/GF/Compile/GFCCtoJS.hs b/src/compiler/GF/Compile/GFCCtoJS.hs deleted file mode 100644 index 4ec12e701..000000000 --- a/src/compiler/GF/Compile/GFCCtoJS.hs +++ /dev/null @@ -1,122 +0,0 @@ -module GF.Compile.GFCCtoJS (pgf2js) where - -import PGF.CId -import PGF.Data hiding (mkStr) -import qualified PGF.Macros as M -import qualified GF.JavaScript.AbsJS as JS -import qualified GF.JavaScript.PrintJS as JS - -import GF.Text.UTF8 -import GF.Data.ErrM -import GF.Infra.Option - -import Control.Monad (mplus) -import Data.Array.Unboxed (UArray) -import qualified Data.Array.IArray as Array -import Data.Maybe (fromMaybe) -import Data.Map (Map) -import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap - -pgf2js :: PGF -> String -pgf2js pgf = - encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]] - where - n = showCId $ absname pgf - as = abstract pgf - cs = Map.assocs (concretes pgf) - start = showCId $ M.lookStartCat pgf - grammar = new "GFGrammar" [js_abstract, js_concrete] - js_abstract = abstract2js start as - js_concrete = JS.EObj $ map (concrete2js n) cs - -abstract2js :: String -> Abstr -> JS.Expr -abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))] - -absdef2js :: (CId,(Type,Int,[Equation])) -> JS.Property -absdef2js (f,(typ,_,_)) = - let (args,cat) = M.catSkeleton typ in - JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)]) - -concrete2js :: String -> (CId,Concr) -> JS.Property -concrete2js n (c, cnc) = - JS.Prop l (new "GFConcrete" ([flags,(JS.EObj $ ((map (cncdef2js n (showCId c)) ds) ++ litslins))] ++ - maybe [] parser2js (parser cnc))) - where - flags = mapToJSObj JS.EStr $ cflags cnc - l = JS.IdentPropName (JS.Ident (showCId c)) - ds = concatMap Map.assocs [lins cnc, opers cnc, lindefs cnc] - litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), - JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), - JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])] - - -cncdef2js :: String -> String -> (CId,Term) -> JS.Property -cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)]) - -term2js :: String -> String -> Term -> JS.Expr -term2js n l t = f t - where - f t = - case t of - R xs -> new "Arr" (map f xs) - P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y] - S xs -> mkSeq (map f xs) - K t -> tokn2js t - V i -> JS.EIndex (JS.EVar children) (JS.EInt i) - C i -> new "Int" [JS.EInt i] - F f -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr (showCId f), JS.EVar children] - FV xs -> new "Variants" (map f xs) - W str x -> new "Suffix" [JS.EStr str, f x] - TM _ -> new "Meta" [] - -tokn2js :: Tokn -> JS.Expr -tokn2js (KS s) = mkStr s -tokn2js (KP ss vs) = mkSeq (map mkStr ss) -- FIXME - -mkStr :: String -> JS.Expr -mkStr s = new "Str" [JS.EStr s] - -mkSeq :: [JS.Expr] -> JS.Expr -mkSeq [x] = x -mkSeq xs = new "Seq" xs - -argIdent :: Integer -> JS.Ident -argIdent n = JS.Ident ("x" ++ show n) - -children :: JS.Ident -children = JS.Ident "cs" - --- Parser -parser2js :: ParserInfo -> [JS.Expr] -parser2js p = [new "Parser" [JS.EObj $ [JS.Prop (JS.IntPropName cat) (JS.EArray (map frule2js (Set.toList set))) | (cat,set) <- IntMap.toList (productions0 p)], - JS.EArray $ (map ffun2js (Array.elems (functions p))), - JS.EArray $ (map seq2js (Array.elems (sequences p))), - JS.EObj $ map cats (Map.assocs (startCats p)), - JS.EInt (totalCats p)]] - where - cats (c,is) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EArray (map JS.EInt is)) - -frule2js :: Production -> JS.Expr -frule2js (FApply funid args) = new "Rule" [JS.EInt funid, JS.EArray (map JS.EInt args)] -frule2js (FCoerce arg) = new "Coerce" [JS.EInt arg] - -ffun2js (FFun f _ lins) = new "FFun" [JS.EStr (showCId f), JS.EArray (map JS.EInt (Array.elems lins))] - -seq2js :: Array.Array FIndex FSymbol -> JS.Expr -seq2js seq = JS.EArray [sym2js s | s <- Array.elems seq] - -sym2js :: FSymbol -> JS.Expr -sym2js (FSymCat n l) = new "Arg" [JS.EInt n, JS.EInt l] -sym2js (FSymLit n l) = new "Lit" [JS.EInt n, JS.EInt l] -sym2js (FSymKS ts) = new "KS" (map JS.EStr ts) -sym2js (FSymKP ts alts) = new "KP" [JS.EArray (map JS.EStr ts), JS.EArray (map alt2js alts)] - -alt2js (Alt ps ts) = new "Alt" [JS.EArray (map JS.EStr ps), JS.EArray (map JS.EStr ts)] - -new :: String -> [JS.Expr] -> JS.Expr -new f xs = JS.ENew (JS.Ident f) xs - -mapToJSObj :: (a -> JS.Expr) -> Map CId a -> JS.Expr -mapToJSObj f m = JS.EObj [ JS.Prop (JS.IdentPropName (JS.Ident (showCId k))) (f v) | (k,v) <- Map.toList m ] diff --git a/src/compiler/GF/Compile/GFCCtoProlog.hs b/src/compiler/GF/Compile/GFCCtoProlog.hs deleted file mode 100644 index 702d4afe5..000000000 --- a/src/compiler/GF/Compile/GFCCtoProlog.hs +++ /dev/null @@ -1,279 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GFCCtoProlog --- Maintainer : Peter Ljunglöf --- Stability : (stable) --- Portability : (portable) --- --- to write a GF grammar into a Prolog module ------------------------------------------------------------------------------ - -module GF.Compile.GFCCtoProlog (grammar2prolog, grammar2prolog_abs) where - -import PGF.CId -import PGF.Data -import PGF.Macros - -import GF.Data.Operations -import GF.Text.UTF8 - -import qualified Data.Map as Map -import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper, ord) -import Data.List (isPrefixOf,mapAccumL) - -grammar2prolog, grammar2prolog_abs :: PGF -> String --- Most prologs have problems with UTF8 encodings, so we skip that: -grammar2prolog = {- encodeUTF8 . -} foldr (++++) [] . pgf2clauses -grammar2prolog_abs = {- encodeUTF8 . -} foldr (++++) [] . pgf2clauses_abs - - -pgf2clauses :: PGF -> [String] -pgf2clauses (PGF absname cncnames gflags abstract concretes) = - [":- " ++ plFact "module" [plp absname, "[]"]] ++ - clauseHeader "%% concrete(?Module)" - [plFact "concrete" [plp cncname] | cncname <- cncnames] ++ - clauseHeader "%% flag(?Flag, ?Value): global flags" - (map (plpFact2 "flag") (Map.assocs gflags)) ++ - plAbstract (absname, abstract) ++ - concatMap plConcrete (Map.assocs concretes) - -pgf2clauses_abs :: PGF -> [String] -pgf2clauses_abs (PGF absname _cncnames gflags abstract _concretes) = - [":- " ++ plFact "module" [plp absname, "[]"]] ++ - clauseHeader "%% flag(?Flag, ?Value): global flags" - (map (plpFact2 "flag") (Map.assocs gflags)) ++ - plAbstract (absname, abstract) - -clauseHeader :: String -> [String] -> [String] -clauseHeader hdr [] = [] -clauseHeader hdr clauses = "":hdr:clauses - - ----------------------------------------------------------------------- --- abstract syntax - -plAbstract :: (CId, Abstr) -> [String] -plAbstract (name, Abstr aflags funs cats _catfuns) = - ["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%", - "%% abstract module: " ++ plp name] ++ - clauseHeader "%% absflag(?Flag, ?Value): flags for abstract syntax" - (map (plpFact2 "absflag") (Map.assocs aflags)) ++ - clauseHeader "%% cat(?Type, ?[X:Type,...])" - (map plCat (Map.assocs cats)) ++ - clauseHeader "%% fun(?Fun, ?Type, ?[X:Type,...])" - (map plFun (Map.assocs funs)) ++ - clauseHeader "%% def(?Fun, ?Expr)" - (concatMap plFundef (Map.assocs funs)) - -plCat :: (CId, [Hypo]) -> String -plCat (cat, hypos) = plFact "cat" (plTypeWithHypos typ) - where ((_,subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos - args = reverse [EFun x | (_,x) <- subst] - typ = DTyp hypos' cat args - -plFun :: (CId, (Type, Int, [Equation])) -> String -plFun (fun, (typ,_,_)) = plFact "fun" (plp fun : plTypeWithHypos typ') - where typ' = snd $ alphaConvert emptyEnv typ - -plTypeWithHypos :: Type -> [String] -plTypeWithHypos (DTyp hypos cat args) = [plTerm (plp cat) (map plp args), plList (map (\(_,x,ty) -> plOper ":" (plp x) (plp ty)) hypos)] - -plFundef :: (CId, (Type,Int,[Equation])) -> [String] -plFundef (fun, (_,_,[])) = [] -plFundef (fun, (_,_,eqs)) = [plFact "def" [plp fun, plp fundef']] - where fundef' = snd $ alphaConvert emptyEnv eqs - - ----------------------------------------------------------------------- --- concrete syntax - -plConcrete :: (CId, Concr) -> [String] -plConcrete (cncname, Concr cflags lins opers lincats lindefs - _printnames _paramlincats _parser) = - ["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%", - "%% concrete module: " ++ plp cncname] ++ - clauseHeader "%% cncflag(?Flag, ?Value): flags for concrete syntax" - (map (mod . plpFact2 "cncflag") (Map.assocs cflags)) ++ - clauseHeader "%% lincat(?Cat, ?Linearization type)" - (map (mod . plpFact2 "lincat") (Map.assocs lincats)) ++ - clauseHeader "%% lindef(?Cat, ?Linearization default)" - (map (mod . plpFact2 "lindef") (Map.assocs lindefs)) ++ - clauseHeader "%% lin(?Fun, ?Linearization)" - (map (mod . plpFact2 "lin") (Map.assocs lins)) ++ - clauseHeader "%% oper(?Oper, ?Linearization)" - (map (mod . plpFact2 "oper") (Map.assocs opers)) - where mod clause = plp cncname ++ ": " ++ clause - - ----------------------------------------------------------------------- --- prolog-printing pgf datatypes - -instance PLPrint Type where - plp (DTyp hypos cat args) | null hypos = result - | otherwise = plOper " -> " (plList (map (\(_,x,ty) -> plOper ":" (plp x) (plp ty)) hypos)) result - where result = plTerm (plp cat) (map plp args) - -instance PLPrint Expr where - plp (EFun x) = plp x - plp (EAbs _ x e)= plOper "^" (plp x) (plp e) - plp (EApp e e') = plOper " * " (plp e) (plp e') - plp (ELit lit) = plp lit - plp (EMeta n) = "Meta_" ++ show n - -instance PLPrint Patt where - plp (PVar x) = plp x - plp (PApp f ps) = plOper " * " (plp f) (plp ps) - plp (PLit lit) = plp lit - -instance PLPrint Equation where - plp (Equ patterns result) = plOper ":" (plp patterns) (plp result) - -instance PLPrint Term where - plp (S terms) = plTerm "s" [plp terms] - plp (C n) = plTerm "c" [show n] - plp (K tokn) = plTerm "k" [plp tokn] - plp (FV trms) = plTerm "fv" [plp trms] - plp (P t1 t2) = plTerm "p" [plp t1, plp t2] - plp (W s trm) = plTerm "w" [plp s, plp trm] - plp (R terms) = plTerm "r" [plp terms] - plp (F oper) = plTerm "f" [plp oper] - plp (V n) = plTerm "v" [show n] - plp (TM str) = plTerm "tm" [plp str] - -{-- more prolog-like syntax for PGF terms, but also more difficult to handle: -instance PLPrint Term where - plp (S terms) = plp terms - plp (C n) = show n - plp (K token) = plp token - plp (FV terms) = prCurlyList (map plp terms) - plp (P t1 t2) = plOper "/" (plp t1) (plp t2) - plp (W s trm) = plOper "+" (plp s) (plp trm) - plp (R terms) = plTerm "r" (map plp terms) - plp (F oper) = plTerm "f" [plp oper] - plp (V n) = plTerm "arg" [show n] - plp (TM str) = plTerm "meta" [plp str] ---} - -instance PLPrint CId where - plp cid | isLogicalVariable str || - cid == wildCId = plVar str - | otherwise = plAtom str - where str = showCId cid - -instance PLPrint Literal where - plp (LStr s) = plp s - plp (LInt n) = plp (show n) - plp (LFlt f) = plp (show f) - -instance PLPrint Tokn where - plp (KS tokn) = plp tokn - plp (KP strs alts) = plTerm "kp" [plp strs, plList [plOper "/" (plp ss1) (plp ss2) | - Alt ss1 ss2 <- alts]] - ----------------------------------------------------------------------- --- basic prolog-printing - -class PLPrint a where - plp :: a -> String - plps :: [a] -> String - plps = plList . map plp - -instance PLPrint Char where - plp c = plAtom [c] - plps s = plAtom s - -instance PLPrint a => PLPrint [a] where - plp = plps - -plpFact2 :: (PLPrint a, PLPrint b) => String -> (a, b) -> String -plpFact2 fun (arg1, arg2) = plFact fun [plp arg1, plp arg2] - -plFact :: String -> [String] -> String -plFact fun args = plTerm fun args ++ "." - -plTerm :: String -> [String] -> String -plTerm fun args = plAtom fun ++ prParenth (prTList ", " args) - -plList :: [String] -> String -plList = prBracket . prTList "," - -plOper :: String -> String -> String -> String -plOper op a b = prParenth (a ++ op ++ b) - -plVar :: String -> String -plVar = varPrefix . concatMap changeNonAlphaNum - where varPrefix var@(c:_) | isAsciiUpper c || c=='_' = var - | otherwise = "_" ++ var - changeNonAlphaNum c | isAlphaNumUnderscore c = [c] - | otherwise = "_" ++ show (ord c) ++ "_" - -plAtom :: String -> String -plAtom "" = "''" -plAtom atom@(c:cs) | isAsciiLower c && all isAlphaNumUnderscore cs - || c == '\'' && cs /= "" && last cs == '\'' = atom - | otherwise = "'" ++ concatMap changeQuote atom ++ "'" - where changeQuote '\'' = "\\'" - changeQuote c = [c] - -isAlphaNumUnderscore :: Char -> Bool -isAlphaNumUnderscore c = isAlphaNum c || c == '_' - - ----------------------------------------------------------------------- --- prolog variables - -createLogicalVariable :: Int -> CId -createLogicalVariable n = mkCId (logicalVariablePrefix ++ show n) - -isLogicalVariable :: String -> Bool -isLogicalVariable = isPrefixOf logicalVariablePrefix - -logicalVariablePrefix :: String -logicalVariablePrefix = "X" - ----------------------------------------------------------------------- --- alpha convert variables to (unique) logical variables --- * this is needed if we want to translate variables to Prolog variables --- * used for abstract syntax, not concrete --- * not (yet?) used for variables bound in pattern equations - -type ConvertEnv = (Int, [(CId,CId)]) - -emptyEnv :: ConvertEnv -emptyEnv = (0, []) - -class AlphaConvert a where - alphaConvert :: ConvertEnv -> a -> (ConvertEnv, a) - -instance AlphaConvert a => AlphaConvert [a] where - alphaConvert env [] = (env, []) - alphaConvert env (a:as) = (env'', a':as') - where (env', a') = alphaConvert env a - (env'', as') = alphaConvert env' as - -instance AlphaConvert Type where - alphaConvert env@(_,subst) (DTyp hypos cat args) - = ((ctr,subst), DTyp hypos' cat args') - where (env', hypos') = mapAccumL alphaConvertHypo env hypos - ((ctr,_), args') = alphaConvert env' args - -alphaConvertHypo env (b,x,typ) = ((ctr+1,(x,x'):subst), (b,x',typ')) - where ((ctr,subst), typ') = alphaConvert env typ - x' = createLogicalVariable ctr - -instance AlphaConvert Expr where - alphaConvert (ctr,subst) (EAbs b x e) = ((ctr',subst), EAbs b x' e') - where ((ctr',_), e') = alphaConvert (ctr+1,(x,x'):subst) e - x' = createLogicalVariable ctr - alphaConvert env (EApp e1 e2) = (env'', EApp e1' e2') - where (env', e1') = alphaConvert env e1 - (env'', e2') = alphaConvert env' e2 - alphaConvert env expr@(EFun i) = (env, maybe expr EFun (lookup i (snd env))) - alphaConvert env expr = (env, expr) - --- pattern variables are not alpha converted --- (but they probably should be...) -instance AlphaConvert Equation where - alphaConvert env@(_,subst) (Equ patterns result) - = ((ctr,subst), Equ patterns result') - where ((ctr,_), result') = alphaConvert env result diff --git a/src/compiler/GF/Compile/GrammarToGFCC.hs b/src/compiler/GF/Compile/GrammarToGFCC.hs deleted file mode 100644 index fb92ef74c..000000000 --- a/src/compiler/GF/Compile/GrammarToGFCC.hs +++ /dev/null @@ -1,587 +0,0 @@ -{-# LANGUAGE PatternGuards #-} -module GF.Compile.GrammarToGFCC (mkCanon2gfcc,addParsers) where - -import GF.Compile.Export -import qualified GF.Compile.GenerateFCFG as FCFG -import qualified GF.Compile.GeneratePMCFG as PMCFG - -import PGF.CId -import qualified PGF.Macros as CM -import qualified PGF.Data as C -import qualified PGF.Data as D -import GF.Grammar.Predef -import GF.Grammar.Printer -import GF.Grammar.Grammar -import qualified GF.Grammar.Lookup as Look -import qualified GF.Grammar as A -import qualified GF.Grammar.Macros as GM -import qualified GF.Compile.Concrete.Compute as Compute ---- -import qualified GF.Infra.Modules as M -import qualified GF.Infra.Option as O - -import GF.Infra.Ident -import GF.Infra.Option -import GF.Data.Operations - -import Data.List -import Data.Char (isDigit,isSpace) -import qualified Data.Map as Map -import qualified Data.ByteString.Char8 as BS -import Text.PrettyPrint -import Debug.Trace ---- - --- when developing, swap commenting ---traceD s t = trace s t -traceD s t = t - - --- the main function: generate PGF from GF. -mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.PGF) -mkCanon2gfcc opts cnc gr = - (showIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon opts abs) gr) - where - abs = err (const c) id $ M.abstractOfConcrete gr c where c = identC (BS.pack cnc) - pars = mkParamLincat gr - --- Adds parsers for all concretes -addParsers :: Options -> D.PGF -> IO D.PGF -addParsers opts pgf = do cncs <- sequence [conv lang cnc | (lang,cnc) <- Map.toList (D.concretes pgf)] - return pgf { D.concretes = Map.fromList cncs } - where - conv lang cnc = do pinfo <- if flag optErasing (erasingFromCnc `addOptions` opts) - then PMCFG.convertConcrete opts (D.abstract pgf) lang cnc - else return $ FCFG.convertConcrete (D.abstract pgf) cnc - return (lang,cnc { D.parser = Just pinfo }) - where - erasingFromCnc = modifyFlags (\o -> o { optErasing = Map.lookup (mkCId "erasing") (D.cflags cnc) == Just "on"}) - --- Generate PGF from GFCM. --- this assumes a grammar translated by canon2canon - -canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.PGF -canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) = - (if dump opts DumpCanon then trace (render (vcat (map (ppModule Qualified) (M.modules cgr)))) else id) $ - D.PGF an cns gflags abs cncs - where - -- abstract - an = (i2i a) - cns = map (i2i . fst) cms - abs = D.Abstr aflags funs cats catfuns - gflags = Map.empty - aflags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF (M.flags abm)] - - mkDef (Just eqs) = [C.Equ ps' (mkExp scope' e) | (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] - mkDef Nothing = [] - - mkArrity (Just a) = a - mkArrity Nothing = 0 - - -- concretes - lfuns = [(f', (mkType [] ty, mkArrity ma, mkDef pty)) | - (f,AbsFun (Just ty) ma pty) <- tree2list (M.jments abm), let f' = i2i f] - funs = Map.fromAscList lfuns - lcats = [(i2i c, snd (mkContext [] cont)) | - (c,AbsCat (Just cont) _) <- tree2list (M.jments abm)] - cats = Map.fromAscList lcats - catfuns = Map.fromList - [(cat,[f | (f, (C.DTyp _ c _,_,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] - - cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,mo) <- cms] - mkConcr lang0 lang mo = - (lang,D.Concr flags lins opers lincats lindefs printnames params fcfg) - where - js = tree2list (M.jments mo) - flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF (M.flags mo)] - opers = Map.fromAscList [] -- opers will be created as optimization - utf = id -- trace (show lang0 +++ show flags) $ - -- if moduleFlag optEncoding (moduleOptions (M.flags mo)) == UTF_8 - -- then id else id - ---- then (trace "decode" D.convertStringsInTerm decodeUTF8) else id - umkTerm = utf . mkTerm - lins = Map.fromAscList - [(f', umkTerm tr) | (f,CncFun _ (Just tr) _) <- js, - let f' = i2i f, exists f'] -- eliminating lins without fun - -- needed even here because of restricted inheritance - lincats = Map.fromAscList - [(i2i c, mkCType ty) | (c,CncCat (Just ty) _ _) <- js] - lindefs = Map.fromAscList - [(i2i c, umkTerm tr) | (c,CncCat _ (Just tr) _) <- js] - printnames = Map.union - (Map.fromAscList [(i2i f, umkTerm tr) | (f,CncFun _ _ (Just tr)) <- js]) - (Map.fromAscList [(i2i f, umkTerm tr) | (f,CncCat _ _ (Just tr)) <- js]) - params = Map.fromAscList - [(i2i c, pars lang0 c) | (c,CncCat (Just ty) _ _) <- js] - fcfg = Nothing - - exists f = Map.member f funs - -i2i :: Ident -> CId -i2i = CId . ident2bs - -b2b :: A.BindType -> C.BindType -b2b A.Explicit = C.Explicit -b2b A.Implicit = C.Implicit - -mkType :: [Ident] -> A.Type -> C.Type -mkType scope t = - case GM.typeForm t of - (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps - in C.DTyp hyps' (i2i cat) (map (mkExp scope') args) - -mkExp :: [Ident] -> A.Term -> C.Expr -mkExp scope t = case GM.termForm t of - Ok (xs,c,args) -> mkAbs xs (mkApp (map snd (reverse xs)++scope) c (map (mkExp scope) args)) - where - mkAbs xs t = foldr (\(b,v) -> C.EAbs (b2b b) (i2i v)) t xs - mkApp scope c args = case c of - Q _ c -> foldl C.EApp (C.EFun (i2i c)) args - QC _ c -> foldl C.EApp (C.EFun (i2i c)) args - Vr x -> case lookup x (zip scope [0..]) of - Just i -> foldl C.EApp (C.EVar i) args - Nothing -> foldl C.EApp (C.EMeta 0) args - EInt i -> C.ELit (C.LInt i) - EFloat f -> C.ELit (C.LFlt f) - K s -> C.ELit (C.LStr s) - Meta i -> C.EMeta i - _ -> C.EMeta 0 - -mkPatt scope p = - case p of - A.PP _ c ps -> let (scope',ps') = mapAccumL mkPatt scope ps - in (scope',C.PApp (i2i c) ps') - A.PV x -> (x:scope,C.PVar (i2i x)) - A.PW -> ( scope,C.PWild) - A.PInt i -> ( scope,C.PLit (C.LInt i)) - A.PFloat f -> ( scope,C.PLit (C.LFlt f)) - A.PString s -> ( scope,C.PLit (C.LStr s)) - - -mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo]) -mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty - in if x == identW - then ( scope,(b2b bt,i2i x,ty')) - else (x:scope,(b2b bt,i2i x,ty'))) scope hyps - -mkTerm :: Term -> C.Term -mkTerm tr = case tr of - Vr (IA _ i) -> C.V i - Vr (IAV _ _ i) -> C.V i - Vr (IC s) | isDigit (BS.last s) -> - C.V ((read . BS.unpack . snd . BS.spanEnd isDigit) s) - ---- from gf parser of gfc - EInt i -> C.C $ fromInteger i - R rs -> C.R [mkTerm t | (_, (_,t)) <- rs] - P t l -> C.P (mkTerm t) (C.C (mkLab l)) - T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------ - V _ cs -> C.R [mkTerm t | t <- cs] - S t p -> C.P (mkTerm t) (mkTerm p) - C s t -> C.S $ concatMap flats [mkTerm x | x <- [s,t]] - FV ts -> C.FV [mkTerm t | t <- ts] - K s -> C.K (C.KS s) ------ K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants - Empty -> C.S [] - App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging - Abs _ _ t -> mkTerm t ---- only on toplevel - Alts (td,tvs) -> - C.K (C.KP (strings td) [C.Alt (strings u) (strings v) | (u,v) <- tvs]) - _ -> prtTrace tr $ C.S [C.K (C.KS (render (A.ppTerm Unqualified 0 tr <+> int 66662)))] ---- for debugging - where - mkLab (LIdent l) = case BS.unpack l of - '_':ds -> (read ds) :: Int - _ -> prtTrace tr $ 66663 - strings t = case t of - K s -> [s] - C u v -> strings u ++ strings v - Strs ss -> concatMap strings ss - _ -> prtTrace tr $ ["66660"] - flats t = case t of - C.S ts -> concatMap flats ts - _ -> [t] - --- encoding PGF-internal lincats as terms -mkCType :: Type -> C.Term -mkCType t = case t of - EInt i -> C.C $ fromInteger i - RecType rs -> C.R [mkCType t | (_, t) <- rs] - Table pt vt -> case pt of - EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt - RecType rs -> mkCType $ foldr Table vt (map snd rs) - _ | Just i <- GM.isTypeInts pt -> C.R $ replicate (fromInteger i) $ mkCType vt - - Sort s | s == cStr -> C.S [] --- Str only - _ | Just i <- GM.isTypeInts t -> C.C $ fromInteger i - _ -> error $ "mkCType " ++ show t - --- encoding showable lincats (as in source gf) as terms -mkParamLincat :: SourceGrammar -> Ident -> Ident -> C.Term -mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do - typ <- Look.lookupLincat sgr lang cat - mkPType typ - where - mkPType typ = case typ of - RecType lts -> do - ts <- mapM (mkPType . snd) lts - return $ C.R [ C.P (kks $ showIdent (label2ident l)) t | ((l,_),t) <- zip lts ts] - Table (RecType lts) v -> do - ps <- mapM (mkPType . snd) lts - v' <- mkPType v - return $ foldr (\p v -> C.S [p,v]) v' ps - Table p v -> do - p' <- mkPType p - v' <- mkPType v - return $ C.S [p',v'] - Sort s | s == cStr -> return $ C.S [] - _ -> return $ - C.FV $ map (kks . filter showable . render . ppTerm Unqualified 0) $ - errVal [] $ Look.allParamValues sgr typ - showable c = not (isSpace c) ---- || (c == ' ') -- to eliminate \n in records - kks = C.K . C.KS - --- return just one module per language - -reorder :: Ident -> SourceGrammar -> SourceGrammar -reorder abs cg = M.MGrammar $ - (abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs poss): - [(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js) poss) - | (c,(fs,js)) <- cncs] - where - poss = emptyBinTree -- positions no longer needed - mos = M.modules cg - adefs = sorted2tree $ sortIds $ - predefADefs ++ Look.allOrigInfos cg abs - predefADefs = - [(c, AbsCat (Just []) Nothing) | c <- [cFloat,cInt,cString]] - aflags = - concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo] - - cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs] - concr la = (flags, - sortIds (predefCDefs ++ jments)) where - jments = Look.allOrigInfos cg la - flags = concatOptions - [M.flags mo | - (i,mo) <- mos, M.isModCnc mo, - Just r <- [lookup i (M.allExtendSpecs cg la)]] - - predefCDefs = - [(c, CncCat (Just GM.defLinType) Nothing Nothing) | c <- [cInt,cFloat,cString]] - - sortIds = sortBy (\ (f,_) (g,_) -> compare f g) - - --- one grammar per language - needed for symtab generation -repartition :: Ident -> SourceGrammar -> [SourceGrammar] -repartition abs cg = - [M.partOfGrammar cg (lang,mo) | - let mos = M.modules cg, - lang <- case M.allConcretes cg abs of - [] -> [abs] -- to make pgf nonempty even when there are no concretes - cncs -> cncs, - let mo = errVal - (error (render (text "no module found for" <+> A.ppIdent lang))) $ M.lookupModule cg lang - ] - --- translate tables and records to arrays, parameters and labels to indices - -canon2canon :: Options -> Ident -> SourceGrammar -> SourceGrammar -canon2canon opts abs cg0 = - (recollect . map cl2cl . repartition abs . purgeGrammar abs) cg0 - where - recollect = M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules - cl2cl = M.MGrammar . js2js . map (c2c p2p) . M.modules - - js2js ms = map (c2c (j2j (M.MGrammar ms))) ms - - c2c f2 (c,mo) = (c, M.replaceJudgements mo $ mapTree f2 (M.jments mo)) - - j2j cg (f,j) = - let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in - case j of - CncFun x (Just tr) z -> CncFun x (Just (debug (t2t (unfactor cg0 tr)))) z - CncCat (Just ty) (Just x) y -> CncCat (Just (ty2ty ty)) (Just (t2t (unfactor cg0 x))) y - _ -> j - where - cg1 = cg - t2t = term2term f cg1 pv - ty2ty = type2type cg1 pv - pv@(labels,untyps,typs) = trs $ paramValues cg1 - - unfactor :: SourceGrammar -> Term -> Term - unfactor gr t = case t of - T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac u) | v <- vals ty] - _ -> GM.composSafeOp unfac t - where - unfac = unfactor gr - vals = err error id . Look.allParamValues gr - restore x u t = case t of - Vr y | y == x -> u - _ -> GM.composSafeOp (restore x u) t - - -- flatten record arguments of param constructors - p2p (f,j) = case j of - ResParam (Just ps) (Just vs) -> - ResParam (Just [(c,concatMap unRec cont) | (c,cont) <- ps]) (Just (map unrec vs)) - _ -> j - unRec (bt,x,ty) = case ty of - RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (Explicit,identW,typ)] - _ -> [(bt,x,ty)] - unrec t = case t of - App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs] - _ -> GM.composSafeOp unrec t - - ----- - trs v = traceD (render (tr v)) v - - tr (labels,untyps,typs) = - (text "LABELS:" <+> - vcat [A.ppIdent c <> char '.' <> hsep (map A.ppLabel l) <+> char '=' <+> text (show i) | ((c,l),i) <- Map.toList labels]) $$ - (text "UNTYPS:" <+> - vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show i) | (t,i) <- Map.toList untyps]) $$ - (text "TYPS: " <+> - vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show (Map.assocs i)) | (t,i) <- Map.toList typs]) ----- - -purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar -purgeGrammar abstr gr = - (M.MGrammar . list . filter complete . purge . M.modules) gr - where - list ms = traceD (render (text "MODULES" <+> hsep (punctuate comma (map (ppIdent . fst) ms)))) ms - purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst) - needed = nub $ concatMap (requiredCanModules isSingle gr) acncs - acncs = abstr : M.allConcretes gr abstr - isSingle = True - complete (i,m) = M.isCompleteModule m --- not . isIncompleteCanon - -type ParamEnv = - (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels - Map.Map Term Integer, -- untyped terms to values - Map.Map Type (Map.Map Term Integer)) -- types to their terms to values - ---- gathers those param types that are actually used in lincats and lin terms -paramValues :: SourceGrammar -> ParamEnv -paramValues cgr = (labels,untyps,typs) where - partyps = nub $ - --- [App (Q (IC "Predef") (IC "Ints")) (EInt i) | i <- [1,9]] ---linTypeInt - [ty | - (_,(_,CncCat (Just ty0) _ _)) <- jments, - ty <- typsFrom ty0 - ] ++ [ - Q m ty | - (m,(ty,ResParam _ _)) <- jments - ] ++ [ty | - (_,(_,CncFun _ (Just tr) _)) <- jments, - ty <- err (const []) snd $ appSTM (typsFromTrm tr) [] - ] - params = [(ty, errVal (traceD ("UNKNOWN PARAM TYPE" +++ show ty) []) $ - Look.allParamValues cgr ty) | ty <- partyps] - typsFrom ty = (if isParam ty then (ty:) else id) $ case ty of - Table p t -> typsFrom p ++ typsFrom t - RecType ls -> concat [typsFrom t | (_, t) <- ls] - _ -> [] - - isParam ty = case ty of - Q _ _ -> True - QC _ _ -> True - RecType rs -> all isParam (map snd rs) - _ -> False - - typsFromTrm :: Term -> STM [Type] Term - typsFromTrm tr = case tr of - R fs -> mapM_ (typsFromField . snd) fs >> return tr - where - typsFromField (mty, t) = case mty of - Just x -> updateSTM (x:) >> typsFromTrm t - _ -> typsFromTrm t - V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr - T (TTyped ty) cs -> - updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr - T (TComp ty) cs -> - updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr - _ -> GM.composOp typsFromTrm tr - - mods = traceD (render (hsep (map (ppIdent . fst) ms))) ms where ms = M.modules cgr - - jments = - [(m,j) | (m,mo) <- mods, j <- tree2list $ M.jments mo] - typs = - Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params] - untyps = - Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs] - lincats = - [(cat,[f | let RecType fs = GM.defLinType, f <- fs]) | cat <- [cInt,cFloat, cString]] ++ - reverse ---- TODO: really those lincats that are reached - ---- reverse is enough to expel overshadowed ones... - [(cat,ls) | (_,(cat,CncCat (Just ty) _ _)) <- jments, - RecType ls <- [unlockTy ty]] - labels = Map.fromList $ concat - [((cat,[lab]),(typ,i)): - [((cat,[LVar v]),(typ,toInteger (mx + v))) | v <- [0,1]] ++ ---- 1 or 2 vars - [((cat,[lab,lab2]),(ty,j)) | - rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]] - | - (cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..], let mx = length ls] - -- go to tables recursively - ---- TODO: even go to deeper records - where - getRec typ = case typ of - RecType rs -> [rs] ---- [unlockTyp rs] -- (sort (unlockTyp ls)) - Table _ t -> getRec t - _ -> [] - -type2type :: SourceGrammar -> ParamEnv -> Type -> Type -type2type cgr env@(labels,untyps,typs) ty = case ty of - RecType rs -> - RecType [(mkLab i, t2t t) | (i,(l, t)) <- zip [0..] (unlockTyp rs)] - Table pt vt -> Table (t2t pt) (t2t vt) - QC _ _ -> look ty - _ -> ty - where - t2t = type2type cgr env - look ty = EInt $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of - Just vs -> length $ Map.assocs vs - _ -> trace ("unknown partype " ++ show ty) 66669 - -term2term :: Ident -> SourceGrammar -> ParamEnv -> Term -> Term -term2term fun cgr env@(labels,untyps,typs) tr = case tr of - App _ _ -> mkValCase (unrec tr) - QC _ _ -> mkValCase tr - R rs -> R [(mkLab i, (Nothing, t2t t)) | - (i,(l,(_,t))) <- zip [0..] (GM.sortRec (unlock rs))] - P t l -> r2r tr - - T (TWild _) _ -> error $ (render (text "wild" <+> ppTerm Qualified 0 tr)) - T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc - T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc - V ty ts -> mkCurry $ V ty [t2t t | t <- ts] - S t p -> mkCurrySel (t2t t) (t2t p) - - _ -> GM.composSafeOp t2t tr - where - t2t = term2term fun cgr env - - unrec t = case t of - App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs] - _ -> GM.composSafeOp unrec t - - mkValCase tr = case appSTM (doVar tr) [] of - Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st - _ -> valNum $ comp tr - - --- this is mainly needed for parameter record projections - ---- was: - comp t = errVal t $ Compute.computeConcreteRec cgr t - - doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term - doVar tr = case getLab tr of - Ok (cat, lab) -> do - k <- readSTM >>= return . length - let tr' = Vr $ identC $ (BS.pack (show k)) ----- - - let tyvs = case Map.lookup (cat,lab) labels of - Just (ty,_) -> case Map.lookup ty typs of - Just vs -> (ty,[t | - (t,_) <- sortBy (\x y -> compare (snd x) (snd y)) - (Map.assocs vs)]) - _ -> error $ render (text "doVar1" <+> A.ppTerm Unqualified 0 ty) - _ -> error $ render (text "doVar2" <+> A.ppTerm Unqualified 0 tr <+> text (show (cat,lab))) ---- debug - updateSTM ((tyvs, (tr', tr)):) - return tr' - _ -> GM.composOp doVar tr - - r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v - - r2r tr@(P p _) = case getLab tr of - Ok (cat,labs) -> P (t2t p) . mkLab $ - maybe (prtTrace tr $ 66664) snd $ - Map.lookup (cat,labs) labels - _ -> K (render (A.ppTerm Unqualified 0 tr <+> prtTrace tr (int 66665))) - - -- this goes recursively into tables (ignored) and records (accumulated) - getLab tr = case tr of - Vr (IA cat _) -> return (identC cat,[]) - Vr (IAV cat _ _) -> return (identC cat,[]) - Vr (IC s) -> return (identC cat,[]) where - cat = BS.takeWhile (/='_') s ---- also to match IAVs; no _ in a cat tolerated - ---- init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser ----- Vr _ -> error $ "getLab " ++ show tr - P p lab2 -> do - (cat,labs) <- getLab p - return (cat,labs++[lab2]) - S p _ -> getLab p - _ -> Bad "getLab" - - - mkCase ((ty,vs),(x,p)) tr = - S (V ty [mkBranch x v tr | v <- vs]) p - mkBranch x t tr = case tr of - _ | tr == x -> t - _ -> GM.composSafeOp (mkBranch x t) tr - - valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps - where - tryFV tr = case GM.appForm tr of - (c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)] - (FV ts,_) -> ts - _ -> [tr] - valNumFV ts = case ts of - [tr] -> let msg = render (text "DEBUG" <+> ppIdent fun <> text ": error in valNum" <+> ppTerm Qualified 0 tr) in - trace msg $ error (showIdent fun) - _ -> FV $ map valNum ts - - mkCurry trm = case trm of - V (RecType [(_,ty)]) ts -> V ty ts - V (RecType ((_,ty):ltys)) ts -> - V ty [mkCurry (V (RecType ltys) cs) | - cs <- chop (product (map (lengthtyp . snd) ltys)) ts] - _ -> trm - lengthtyp ty = case Map.lookup ty typs of - Just m -> length (Map.assocs m) - _ -> error $ "length of type " ++ show ty - chop i xs = case splitAt i xs of - (xs1,[]) -> [xs1] - (xs1,xs2) -> xs1:chop i xs2 - - - mkCurrySel t p = S t p -- done properly in CheckGFCC - - -mkLab k = LIdent (BS.pack ("_" ++ show k)) - --- remove lock fields; in fact, any empty records and record types -unlock = filter notlock where - notlock (l,(_, t)) = case t of --- need not look at l - R [] -> False - RecType [] -> False - _ -> True - -unlockTyp = filter notlock - -notlock (l, t) = case t of --- need not look at l - RecType [] -> False - _ -> True - -unlockTy ty = case ty of - RecType ls -> RecType $ GM.sortRec [(l, unlockTy t) | (l,t) <- ls, notlock (l,t)] - _ -> GM.composSafeOp unlockTy ty - - -prtTrace tr n = - trace (render (text "-- INTERNAL COMPILER ERROR" <+> A.ppTerm Unqualified 0 tr $$ text (show n))) n -prTrace tr n = trace (render (text "-- OBSERVE" <+> A.ppTerm Unqualified 0 tr <+> text (show n) <+> text (show tr))) n - - --- | this function finds out what modules are really needed in the canonical gr. --- its argument is typically a concrete module name -requiredCanModules :: (Ord i, Show i) => Bool -> M.MGrammar i a -> i -> [i] -requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where - exts = M.allExtends gr c - ops = if isSingle - then map fst (M.modules gr) - else iterFix (concatMap more) $ exts - more i = errVal [] $ do - m <- M.lookupModule gr i - return $ M.extends m ++ [o | o <- map M.openedModule (M.opens m)] - notReuse i = errVal True $ do - m <- M.lookupModule gr i - return $ M.isModRes m -- to exclude reused Cnc and Abs from required diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs new file mode 100644 index 000000000..ce7e5be73 --- /dev/null +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -0,0 +1,587 @@ +{-# LANGUAGE PatternGuards #-} +module GF.Compile.GrammarToPGF (mkCanon2gfcc,addParsers) where + +import GF.Compile.Export +import qualified GF.Compile.GenerateFCFG as FCFG +import qualified GF.Compile.GeneratePMCFG as PMCFG + +import PGF.CId +import qualified PGF.Macros as CM +import qualified PGF.Data as C +import qualified PGF.Data as D +import GF.Grammar.Predef +import GF.Grammar.Printer +import GF.Grammar.Grammar +import qualified GF.Grammar.Lookup as Look +import qualified GF.Grammar as A +import qualified GF.Grammar.Macros as GM +import qualified GF.Compile.Concrete.Compute as Compute ---- +import qualified GF.Infra.Modules as M +import qualified GF.Infra.Option as O + +import GF.Infra.Ident +import GF.Infra.Option +import GF.Data.Operations + +import Data.List +import Data.Char (isDigit,isSpace) +import qualified Data.Map as Map +import qualified Data.ByteString.Char8 as BS +import Text.PrettyPrint +import Debug.Trace ---- + +-- when developing, swap commenting +--traceD s t = trace s t +traceD s t = t + + +-- the main function: generate PGF from GF. +mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.PGF) +mkCanon2gfcc opts cnc gr = + (showIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon opts abs) gr) + where + abs = err (const c) id $ M.abstractOfConcrete gr c where c = identC (BS.pack cnc) + pars = mkParamLincat gr + +-- Adds parsers for all concretes +addParsers :: Options -> D.PGF -> IO D.PGF +addParsers opts pgf = do cncs <- sequence [conv lang cnc | (lang,cnc) <- Map.toList (D.concretes pgf)] + return pgf { D.concretes = Map.fromList cncs } + where + conv lang cnc = do pinfo <- if flag optErasing (erasingFromCnc `addOptions` opts) + then PMCFG.convertConcrete opts (D.abstract pgf) lang cnc + else return $ FCFG.convertConcrete (D.abstract pgf) cnc + return (lang,cnc { D.parser = Just pinfo }) + where + erasingFromCnc = modifyFlags (\o -> o { optErasing = Map.lookup (mkCId "erasing") (D.cflags cnc) == Just "on"}) + +-- Generate PGF from GFCM. +-- this assumes a grammar translated by canon2canon + +canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.PGF +canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) = + (if dump opts DumpCanon then trace (render (vcat (map (ppModule Qualified) (M.modules cgr)))) else id) $ + D.PGF an cns gflags abs cncs + where + -- abstract + an = (i2i a) + cns = map (i2i . fst) cms + abs = D.Abstr aflags funs cats catfuns + gflags = Map.empty + aflags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF (M.flags abm)] + + mkDef (Just eqs) = [C.Equ ps' (mkExp scope' e) | (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] + mkDef Nothing = [] + + mkArrity (Just a) = a + mkArrity Nothing = 0 + + -- concretes + lfuns = [(f', (mkType [] ty, mkArrity ma, mkDef pty)) | + (f,AbsFun (Just ty) ma pty) <- tree2list (M.jments abm), let f' = i2i f] + funs = Map.fromAscList lfuns + lcats = [(i2i c, snd (mkContext [] cont)) | + (c,AbsCat (Just cont) _) <- tree2list (M.jments abm)] + cats = Map.fromAscList lcats + catfuns = Map.fromList + [(cat,[f | (f, (C.DTyp _ c _,_,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] + + cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,mo) <- cms] + mkConcr lang0 lang mo = + (lang,D.Concr flags lins opers lincats lindefs printnames params fcfg) + where + js = tree2list (M.jments mo) + flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF (M.flags mo)] + opers = Map.fromAscList [] -- opers will be created as optimization + utf = id -- trace (show lang0 +++ show flags) $ + -- if moduleFlag optEncoding (moduleOptions (M.flags mo)) == UTF_8 + -- then id else id + ---- then (trace "decode" D.convertStringsInTerm decodeUTF8) else id + umkTerm = utf . mkTerm + lins = Map.fromAscList + [(f', umkTerm tr) | (f,CncFun _ (Just tr) _) <- js, + let f' = i2i f, exists f'] -- eliminating lins without fun + -- needed even here because of restricted inheritance + lincats = Map.fromAscList + [(i2i c, mkCType ty) | (c,CncCat (Just ty) _ _) <- js] + lindefs = Map.fromAscList + [(i2i c, umkTerm tr) | (c,CncCat _ (Just tr) _) <- js] + printnames = Map.union + (Map.fromAscList [(i2i f, umkTerm tr) | (f,CncFun _ _ (Just tr)) <- js]) + (Map.fromAscList [(i2i f, umkTerm tr) | (f,CncCat _ _ (Just tr)) <- js]) + params = Map.fromAscList + [(i2i c, pars lang0 c) | (c,CncCat (Just ty) _ _) <- js] + fcfg = Nothing + + exists f = Map.member f funs + +i2i :: Ident -> CId +i2i = CId . ident2bs + +b2b :: A.BindType -> C.BindType +b2b A.Explicit = C.Explicit +b2b A.Implicit = C.Implicit + +mkType :: [Ident] -> A.Type -> C.Type +mkType scope t = + case GM.typeForm t of + (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps + in C.DTyp hyps' (i2i cat) (map (mkExp scope') args) + +mkExp :: [Ident] -> A.Term -> C.Expr +mkExp scope t = case GM.termForm t of + Ok (xs,c,args) -> mkAbs xs (mkApp (map snd (reverse xs)++scope) c (map (mkExp scope) args)) + where + mkAbs xs t = foldr (\(b,v) -> C.EAbs (b2b b) (i2i v)) t xs + mkApp scope c args = case c of + Q _ c -> foldl C.EApp (C.EFun (i2i c)) args + QC _ c -> foldl C.EApp (C.EFun (i2i c)) args + Vr x -> case lookup x (zip scope [0..]) of + Just i -> foldl C.EApp (C.EVar i) args + Nothing -> foldl C.EApp (C.EMeta 0) args + EInt i -> C.ELit (C.LInt i) + EFloat f -> C.ELit (C.LFlt f) + K s -> C.ELit (C.LStr s) + Meta i -> C.EMeta i + _ -> C.EMeta 0 + +mkPatt scope p = + case p of + A.PP _ c ps -> let (scope',ps') = mapAccumL mkPatt scope ps + in (scope',C.PApp (i2i c) ps') + A.PV x -> (x:scope,C.PVar (i2i x)) + A.PW -> ( scope,C.PWild) + A.PInt i -> ( scope,C.PLit (C.LInt i)) + A.PFloat f -> ( scope,C.PLit (C.LFlt f)) + A.PString s -> ( scope,C.PLit (C.LStr s)) + + +mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo]) +mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty + in if x == identW + then ( scope,(b2b bt,i2i x,ty')) + else (x:scope,(b2b bt,i2i x,ty'))) scope hyps + +mkTerm :: Term -> C.Term +mkTerm tr = case tr of + Vr (IA _ i) -> C.V i + Vr (IAV _ _ i) -> C.V i + Vr (IC s) | isDigit (BS.last s) -> + C.V ((read . BS.unpack . snd . BS.spanEnd isDigit) s) + ---- from gf parser of gfc + EInt i -> C.C $ fromInteger i + R rs -> C.R [mkTerm t | (_, (_,t)) <- rs] + P t l -> C.P (mkTerm t) (C.C (mkLab l)) + T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------ + V _ cs -> C.R [mkTerm t | t <- cs] + S t p -> C.P (mkTerm t) (mkTerm p) + C s t -> C.S $ concatMap flats [mkTerm x | x <- [s,t]] + FV ts -> C.FV [mkTerm t | t <- ts] + K s -> C.K (C.KS s) +----- K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants + Empty -> C.S [] + App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging + Abs _ _ t -> mkTerm t ---- only on toplevel + Alts (td,tvs) -> + C.K (C.KP (strings td) [C.Alt (strings u) (strings v) | (u,v) <- tvs]) + _ -> prtTrace tr $ C.S [C.K (C.KS (render (A.ppTerm Unqualified 0 tr <+> int 66662)))] ---- for debugging + where + mkLab (LIdent l) = case BS.unpack l of + '_':ds -> (read ds) :: Int + _ -> prtTrace tr $ 66663 + strings t = case t of + K s -> [s] + C u v -> strings u ++ strings v + Strs ss -> concatMap strings ss + _ -> prtTrace tr $ ["66660"] + flats t = case t of + C.S ts -> concatMap flats ts + _ -> [t] + +-- encoding PGF-internal lincats as terms +mkCType :: Type -> C.Term +mkCType t = case t of + EInt i -> C.C $ fromInteger i + RecType rs -> C.R [mkCType t | (_, t) <- rs] + Table pt vt -> case pt of + EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt + RecType rs -> mkCType $ foldr Table vt (map snd rs) + _ | Just i <- GM.isTypeInts pt -> C.R $ replicate (fromInteger i) $ mkCType vt + + Sort s | s == cStr -> C.S [] --- Str only + _ | Just i <- GM.isTypeInts t -> C.C $ fromInteger i + _ -> error $ "mkCType " ++ show t + +-- encoding showable lincats (as in source gf) as terms +mkParamLincat :: SourceGrammar -> Ident -> Ident -> C.Term +mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do + typ <- Look.lookupLincat sgr lang cat + mkPType typ + where + mkPType typ = case typ of + RecType lts -> do + ts <- mapM (mkPType . snd) lts + return $ C.R [ C.P (kks $ showIdent (label2ident l)) t | ((l,_),t) <- zip lts ts] + Table (RecType lts) v -> do + ps <- mapM (mkPType . snd) lts + v' <- mkPType v + return $ foldr (\p v -> C.S [p,v]) v' ps + Table p v -> do + p' <- mkPType p + v' <- mkPType v + return $ C.S [p',v'] + Sort s | s == cStr -> return $ C.S [] + _ -> return $ + C.FV $ map (kks . filter showable . render . ppTerm Unqualified 0) $ + errVal [] $ Look.allParamValues sgr typ + showable c = not (isSpace c) ---- || (c == ' ') -- to eliminate \n in records + kks = C.K . C.KS + +-- return just one module per language + +reorder :: Ident -> SourceGrammar -> SourceGrammar +reorder abs cg = M.MGrammar $ + (abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs poss): + [(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js) poss) + | (c,(fs,js)) <- cncs] + where + poss = emptyBinTree -- positions no longer needed + mos = M.modules cg + adefs = sorted2tree $ sortIds $ + predefADefs ++ Look.allOrigInfos cg abs + predefADefs = + [(c, AbsCat (Just []) Nothing) | c <- [cFloat,cInt,cString]] + aflags = + concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo] + + cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs] + concr la = (flags, + sortIds (predefCDefs ++ jments)) where + jments = Look.allOrigInfos cg la + flags = concatOptions + [M.flags mo | + (i,mo) <- mos, M.isModCnc mo, + Just r <- [lookup i (M.allExtendSpecs cg la)]] + + predefCDefs = + [(c, CncCat (Just GM.defLinType) Nothing Nothing) | c <- [cInt,cFloat,cString]] + + sortIds = sortBy (\ (f,_) (g,_) -> compare f g) + + +-- one grammar per language - needed for symtab generation +repartition :: Ident -> SourceGrammar -> [SourceGrammar] +repartition abs cg = + [M.partOfGrammar cg (lang,mo) | + let mos = M.modules cg, + lang <- case M.allConcretes cg abs of + [] -> [abs] -- to make pgf nonempty even when there are no concretes + cncs -> cncs, + let mo = errVal + (error (render (text "no module found for" <+> A.ppIdent lang))) $ M.lookupModule cg lang + ] + +-- translate tables and records to arrays, parameters and labels to indices + +canon2canon :: Options -> Ident -> SourceGrammar -> SourceGrammar +canon2canon opts abs cg0 = + (recollect . map cl2cl . repartition abs . purgeGrammar abs) cg0 + where + recollect = M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules + cl2cl = M.MGrammar . js2js . map (c2c p2p) . M.modules + + js2js ms = map (c2c (j2j (M.MGrammar ms))) ms + + c2c f2 (c,mo) = (c, M.replaceJudgements mo $ mapTree f2 (M.jments mo)) + + j2j cg (f,j) = + let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in + case j of + CncFun x (Just tr) z -> CncFun x (Just (debug (t2t (unfactor cg0 tr)))) z + CncCat (Just ty) (Just x) y -> CncCat (Just (ty2ty ty)) (Just (t2t (unfactor cg0 x))) y + _ -> j + where + cg1 = cg + t2t = term2term f cg1 pv + ty2ty = type2type cg1 pv + pv@(labels,untyps,typs) = trs $ paramValues cg1 + + unfactor :: SourceGrammar -> Term -> Term + unfactor gr t = case t of + T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac u) | v <- vals ty] + _ -> GM.composSafeOp unfac t + where + unfac = unfactor gr + vals = err error id . Look.allParamValues gr + restore x u t = case t of + Vr y | y == x -> u + _ -> GM.composSafeOp (restore x u) t + + -- flatten record arguments of param constructors + p2p (f,j) = case j of + ResParam (Just ps) (Just vs) -> + ResParam (Just [(c,concatMap unRec cont) | (c,cont) <- ps]) (Just (map unrec vs)) + _ -> j + unRec (bt,x,ty) = case ty of + RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (Explicit,identW,typ)] + _ -> [(bt,x,ty)] + unrec t = case t of + App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs] + _ -> GM.composSafeOp unrec t + + +---- + trs v = traceD (render (tr v)) v + + tr (labels,untyps,typs) = + (text "LABELS:" <+> + vcat [A.ppIdent c <> char '.' <> hsep (map A.ppLabel l) <+> char '=' <+> text (show i) | ((c,l),i) <- Map.toList labels]) $$ + (text "UNTYPS:" <+> + vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show i) | (t,i) <- Map.toList untyps]) $$ + (text "TYPS: " <+> + vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show (Map.assocs i)) | (t,i) <- Map.toList typs]) +---- + +purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar +purgeGrammar abstr gr = + (M.MGrammar . list . filter complete . purge . M.modules) gr + where + list ms = traceD (render (text "MODULES" <+> hsep (punctuate comma (map (ppIdent . fst) ms)))) ms + purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst) + needed = nub $ concatMap (requiredCanModules isSingle gr) acncs + acncs = abstr : M.allConcretes gr abstr + isSingle = True + complete (i,m) = M.isCompleteModule m --- not . isIncompleteCanon + +type ParamEnv = + (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels + Map.Map Term Integer, -- untyped terms to values + Map.Map Type (Map.Map Term Integer)) -- types to their terms to values + +--- gathers those param types that are actually used in lincats and lin terms +paramValues :: SourceGrammar -> ParamEnv +paramValues cgr = (labels,untyps,typs) where + partyps = nub $ + --- [App (Q (IC "Predef") (IC "Ints")) (EInt i) | i <- [1,9]] ---linTypeInt + [ty | + (_,(_,CncCat (Just ty0) _ _)) <- jments, + ty <- typsFrom ty0 + ] ++ [ + Q m ty | + (m,(ty,ResParam _ _)) <- jments + ] ++ [ty | + (_,(_,CncFun _ (Just tr) _)) <- jments, + ty <- err (const []) snd $ appSTM (typsFromTrm tr) [] + ] + params = [(ty, errVal (traceD ("UNKNOWN PARAM TYPE" +++ show ty) []) $ + Look.allParamValues cgr ty) | ty <- partyps] + typsFrom ty = (if isParam ty then (ty:) else id) $ case ty of + Table p t -> typsFrom p ++ typsFrom t + RecType ls -> concat [typsFrom t | (_, t) <- ls] + _ -> [] + + isParam ty = case ty of + Q _ _ -> True + QC _ _ -> True + RecType rs -> all isParam (map snd rs) + _ -> False + + typsFromTrm :: Term -> STM [Type] Term + typsFromTrm tr = case tr of + R fs -> mapM_ (typsFromField . snd) fs >> return tr + where + typsFromField (mty, t) = case mty of + Just x -> updateSTM (x:) >> typsFromTrm t + _ -> typsFromTrm t + V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr + T (TTyped ty) cs -> + updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr + T (TComp ty) cs -> + updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr + _ -> GM.composOp typsFromTrm tr + + mods = traceD (render (hsep (map (ppIdent . fst) ms))) ms where ms = M.modules cgr + + jments = + [(m,j) | (m,mo) <- mods, j <- tree2list $ M.jments mo] + typs = + Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params] + untyps = + Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs] + lincats = + [(cat,[f | let RecType fs = GM.defLinType, f <- fs]) | cat <- [cInt,cFloat, cString]] ++ + reverse ---- TODO: really those lincats that are reached + ---- reverse is enough to expel overshadowed ones... + [(cat,ls) | (_,(cat,CncCat (Just ty) _ _)) <- jments, + RecType ls <- [unlockTy ty]] + labels = Map.fromList $ concat + [((cat,[lab]),(typ,i)): + [((cat,[LVar v]),(typ,toInteger (mx + v))) | v <- [0,1]] ++ ---- 1 or 2 vars + [((cat,[lab,lab2]),(ty,j)) | + rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]] + | + (cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..], let mx = length ls] + -- go to tables recursively + ---- TODO: even go to deeper records + where + getRec typ = case typ of + RecType rs -> [rs] ---- [unlockTyp rs] -- (sort (unlockTyp ls)) + Table _ t -> getRec t + _ -> [] + +type2type :: SourceGrammar -> ParamEnv -> Type -> Type +type2type cgr env@(labels,untyps,typs) ty = case ty of + RecType rs -> + RecType [(mkLab i, t2t t) | (i,(l, t)) <- zip [0..] (unlockTyp rs)] + Table pt vt -> Table (t2t pt) (t2t vt) + QC _ _ -> look ty + _ -> ty + where + t2t = type2type cgr env + look ty = EInt $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of + Just vs -> length $ Map.assocs vs + _ -> trace ("unknown partype " ++ show ty) 66669 + +term2term :: Ident -> SourceGrammar -> ParamEnv -> Term -> Term +term2term fun cgr env@(labels,untyps,typs) tr = case tr of + App _ _ -> mkValCase (unrec tr) + QC _ _ -> mkValCase tr + R rs -> R [(mkLab i, (Nothing, t2t t)) | + (i,(l,(_,t))) <- zip [0..] (GM.sortRec (unlock rs))] + P t l -> r2r tr + + T (TWild _) _ -> error $ (render (text "wild" <+> ppTerm Qualified 0 tr)) + T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc + T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc + V ty ts -> mkCurry $ V ty [t2t t | t <- ts] + S t p -> mkCurrySel (t2t t) (t2t p) + + _ -> GM.composSafeOp t2t tr + where + t2t = term2term fun cgr env + + unrec t = case t of + App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs] + _ -> GM.composSafeOp unrec t + + mkValCase tr = case appSTM (doVar tr) [] of + Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st + _ -> valNum $ comp tr + + --- this is mainly needed for parameter record projections + ---- was: + comp t = errVal t $ Compute.computeConcreteRec cgr t + + doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term + doVar tr = case getLab tr of + Ok (cat, lab) -> do + k <- readSTM >>= return . length + let tr' = Vr $ identC $ (BS.pack (show k)) ----- + + let tyvs = case Map.lookup (cat,lab) labels of + Just (ty,_) -> case Map.lookup ty typs of + Just vs -> (ty,[t | + (t,_) <- sortBy (\x y -> compare (snd x) (snd y)) + (Map.assocs vs)]) + _ -> error $ render (text "doVar1" <+> A.ppTerm Unqualified 0 ty) + _ -> error $ render (text "doVar2" <+> A.ppTerm Unqualified 0 tr <+> text (show (cat,lab))) ---- debug + updateSTM ((tyvs, (tr', tr)):) + return tr' + _ -> GM.composOp doVar tr + + r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v + + r2r tr@(P p _) = case getLab tr of + Ok (cat,labs) -> P (t2t p) . mkLab $ + maybe (prtTrace tr $ 66664) snd $ + Map.lookup (cat,labs) labels + _ -> K (render (A.ppTerm Unqualified 0 tr <+> prtTrace tr (int 66665))) + + -- this goes recursively into tables (ignored) and records (accumulated) + getLab tr = case tr of + Vr (IA cat _) -> return (identC cat,[]) + Vr (IAV cat _ _) -> return (identC cat,[]) + Vr (IC s) -> return (identC cat,[]) where + cat = BS.takeWhile (/='_') s ---- also to match IAVs; no _ in a cat tolerated + ---- init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser +---- Vr _ -> error $ "getLab " ++ show tr + P p lab2 -> do + (cat,labs) <- getLab p + return (cat,labs++[lab2]) + S p _ -> getLab p + _ -> Bad "getLab" + + + mkCase ((ty,vs),(x,p)) tr = + S (V ty [mkBranch x v tr | v <- vs]) p + mkBranch x t tr = case tr of + _ | tr == x -> t + _ -> GM.composSafeOp (mkBranch x t) tr + + valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps + where + tryFV tr = case GM.appForm tr of + (c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)] + (FV ts,_) -> ts + _ -> [tr] + valNumFV ts = case ts of + [tr] -> let msg = render (text "DEBUG" <+> ppIdent fun <> text ": error in valNum" <+> ppTerm Qualified 0 tr) in + trace msg $ error (showIdent fun) + _ -> FV $ map valNum ts + + mkCurry trm = case trm of + V (RecType [(_,ty)]) ts -> V ty ts + V (RecType ((_,ty):ltys)) ts -> + V ty [mkCurry (V (RecType ltys) cs) | + cs <- chop (product (map (lengthtyp . snd) ltys)) ts] + _ -> trm + lengthtyp ty = case Map.lookup ty typs of + Just m -> length (Map.assocs m) + _ -> error $ "length of type " ++ show ty + chop i xs = case splitAt i xs of + (xs1,[]) -> [xs1] + (xs1,xs2) -> xs1:chop i xs2 + + + mkCurrySel t p = S t p -- done properly in CheckGFCC + + +mkLab k = LIdent (BS.pack ("_" ++ show k)) + +-- remove lock fields; in fact, any empty records and record types +unlock = filter notlock where + notlock (l,(_, t)) = case t of --- need not look at l + R [] -> False + RecType [] -> False + _ -> True + +unlockTyp = filter notlock + +notlock (l, t) = case t of --- need not look at l + RecType [] -> False + _ -> True + +unlockTy ty = case ty of + RecType ls -> RecType $ GM.sortRec [(l, unlockTy t) | (l,t) <- ls, notlock (l,t)] + _ -> GM.composSafeOp unlockTy ty + + +prtTrace tr n = + trace (render (text "-- INTERNAL COMPILER ERROR" <+> A.ppTerm Unqualified 0 tr $$ text (show n))) n +prTrace tr n = trace (render (text "-- OBSERVE" <+> A.ppTerm Unqualified 0 tr <+> text (show n) <+> text (show tr))) n + + +-- | this function finds out what modules are really needed in the canonical gr. +-- its argument is typically a concrete module name +requiredCanModules :: (Ord i, Show i) => Bool -> M.MGrammar i a -> i -> [i] +requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where + exts = M.allExtends gr c + ops = if isSingle + then map fst (M.modules gr) + else iterFix (concatMap more) $ exts + more i = errVal [] $ do + m <- M.lookupModule gr i + return $ M.extends m ++ [o | o <- map M.openedModule (M.opens m)] + notReuse i = errVal True $ do + m <- M.lookupModule gr i + return $ M.isModRes m -- to exclude reused Cnc and Abs from required diff --git a/src/compiler/GF/Compile/OptimizeGFCC.hs b/src/compiler/GF/Compile/OptimizeGFCC.hs deleted file mode 100644 index 2a218e1bb..000000000 --- a/src/compiler/GF/Compile/OptimizeGFCC.hs +++ /dev/null @@ -1,121 +0,0 @@ -module GF.Compile.OptimizeGFCC where - -import PGF.CId -import PGF.Data -import PGF.Macros - -import GF.Data.Operations - -import Data.List -import qualified Data.Map as Map - - --- back-end optimization: --- suffix analysis followed by common subexpression elimination - -optPGF :: PGF -> PGF -optPGF = cseOptimize . suffixOptimize - -suffixOptimize :: PGF -> PGF -suffixOptimize = mapConcretes opt - where - opt cnc = cnc { - lins = Map.map optTerm (lins cnc), - lindefs = Map.map optTerm (lindefs cnc), - printnames = Map.map optTerm (printnames cnc) - } - -cseOptimize :: PGF -> PGF -cseOptimize = mapConcretes subex - --- analyse word form lists into prefix + suffixes --- suffix sets can later be shared by subex elim - -optTerm :: Term -> Term -optTerm tr = case tr of - R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | K (KS s) <- ts] - R ts -> R $ map optTerm ts - P t v -> P (optTerm t) v - _ -> tr - where - optToks ss = prf : suffs where - prf = pref (head ss) (tail ss) - suffs = map (drop (length prf)) ss - pref cand ss = case ss of - s1:ss2 -> if isPrefixOf cand s1 then pref cand ss2 else pref (init cand) ss - _ -> cand - isK t = case t of - K (KS _) -> True - _ -> False - mkSuff ("":ws) = R (map (K . KS) ws) - mkSuff (p:ws) = W p (R (map (K . KS) ws)) - - --- common subexpression elimination - ----subex :: [(CId,Term)] -> [(CId,Term)] -subex :: Concr -> Concr -subex cnc = err error id $ do - (tree,_) <- appSTM (getSubtermsMod cnc) (Map.empty,0) - return $ addSubexpConsts tree cnc - -type TermList = Map.Map Term (Int,Int) -- number of occs, id -type TermM a = STM (TermList,Int) a - -addSubexpConsts :: TermList -> Concr -> Concr -addSubexpConsts tree cnc = cnc { - opers = Map.fromList [(f,recomp f trm) | (f,trm) <- ops], - lins = rec lins, - lindefs = rec lindefs, - printnames = rec printnames - } - where - ops = [(fid id, trm) | (trm,(_,id)) <- Map.assocs tree] - mkOne (f,trm) = (f, recomp f trm) - recomp f t = case Map.lookup t tree of - Just (_,id) | fid id /= f -> F $ fid id -- not to replace oper itself - _ -> case t of - R ts -> R $ map (recomp f) ts - S ts -> S $ map (recomp f) ts - W s t -> W s (recomp f t) - P t p -> P (recomp f t) (recomp f p) - _ -> t - fid n = mkCId $ "_" ++ show n - rec field = Map.fromAscList [(f,recomp f trm) | (f,trm) <- Map.assocs (field cnc)] - - -getSubtermsMod :: Concr -> TermM TermList -getSubtermsMod cnc = do - mapM getSubterms (Map.assocs (lins cnc)) - mapM getSubterms (Map.assocs (lindefs cnc)) - mapM getSubterms (Map.assocs (printnames cnc)) - (tree0,_) <- readSTM - return $ Map.filter (\ (nu,_) -> nu > 1) tree0 - where - getSubterms (f,trm) = collectSubterms trm >> return () - -collectSubterms :: Term -> TermM () -collectSubterms t = case t of - R ts -> do - mapM collectSubterms ts - add t - S ts -> do - mapM collectSubterms ts - add t - W s u -> do - collectSubterms u - add t - P p u -> do - collectSubterms p - collectSubterms u - add t - _ -> return () - where - add t = do - (ts,i) <- readSTM - let - ((count,id),next) = case Map.lookup t ts of - Just (nu,id) -> ((nu+1,id), i) - _ -> ((1, i ), i+1) - writeSTM (Map.insert t (count,id) ts, next) - diff --git a/src/compiler/GF/Compile/OptimizePGF.hs b/src/compiler/GF/Compile/OptimizePGF.hs new file mode 100644 index 000000000..b23560437 --- /dev/null +++ b/src/compiler/GF/Compile/OptimizePGF.hs @@ -0,0 +1,121 @@ +module GF.Compile.OptimizePGF where + +import PGF.CId +import PGF.Data +import PGF.Macros + +import GF.Data.Operations + +import Data.List +import qualified Data.Map as Map + + +-- back-end optimization: +-- suffix analysis followed by common subexpression elimination + +optPGF :: PGF -> PGF +optPGF = cseOptimize . suffixOptimize + +suffixOptimize :: PGF -> PGF +suffixOptimize = mapConcretes opt + where + opt cnc = cnc { + lins = Map.map optTerm (lins cnc), + lindefs = Map.map optTerm (lindefs cnc), + printnames = Map.map optTerm (printnames cnc) + } + +cseOptimize :: PGF -> PGF +cseOptimize = mapConcretes subex + +-- analyse word form lists into prefix + suffixes +-- suffix sets can later be shared by subex elim + +optTerm :: Term -> Term +optTerm tr = case tr of + R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | K (KS s) <- ts] + R ts -> R $ map optTerm ts + P t v -> P (optTerm t) v + _ -> tr + where + optToks ss = prf : suffs where + prf = pref (head ss) (tail ss) + suffs = map (drop (length prf)) ss + pref cand ss = case ss of + s1:ss2 -> if isPrefixOf cand s1 then pref cand ss2 else pref (init cand) ss + _ -> cand + isK t = case t of + K (KS _) -> True + _ -> False + mkSuff ("":ws) = R (map (K . KS) ws) + mkSuff (p:ws) = W p (R (map (K . KS) ws)) + + +-- common subexpression elimination + +---subex :: [(CId,Term)] -> [(CId,Term)] +subex :: Concr -> Concr +subex cnc = err error id $ do + (tree,_) <- appSTM (getSubtermsMod cnc) (Map.empty,0) + return $ addSubexpConsts tree cnc + +type TermList = Map.Map Term (Int,Int) -- number of occs, id +type TermM a = STM (TermList,Int) a + +addSubexpConsts :: TermList -> Concr -> Concr +addSubexpConsts tree cnc = cnc { + opers = Map.fromList [(f,recomp f trm) | (f,trm) <- ops], + lins = rec lins, + lindefs = rec lindefs, + printnames = rec printnames + } + where + ops = [(fid id, trm) | (trm,(_,id)) <- Map.assocs tree] + mkOne (f,trm) = (f, recomp f trm) + recomp f t = case Map.lookup t tree of + Just (_,id) | fid id /= f -> F $ fid id -- not to replace oper itself + _ -> case t of + R ts -> R $ map (recomp f) ts + S ts -> S $ map (recomp f) ts + W s t -> W s (recomp f t) + P t p -> P (recomp f t) (recomp f p) + _ -> t + fid n = mkCId $ "_" ++ show n + rec field = Map.fromAscList [(f,recomp f trm) | (f,trm) <- Map.assocs (field cnc)] + + +getSubtermsMod :: Concr -> TermM TermList +getSubtermsMod cnc = do + mapM getSubterms (Map.assocs (lins cnc)) + mapM getSubterms (Map.assocs (lindefs cnc)) + mapM getSubterms (Map.assocs (printnames cnc)) + (tree0,_) <- readSTM + return $ Map.filter (\ (nu,_) -> nu > 1) tree0 + where + getSubterms (f,trm) = collectSubterms trm >> return () + +collectSubterms :: Term -> TermM () +collectSubterms t = case t of + R ts -> do + mapM collectSubterms ts + add t + S ts -> do + mapM collectSubterms ts + add t + W s u -> do + collectSubterms u + add t + P p u -> do + collectSubterms p + collectSubterms u + add t + _ -> return () + where + add t = do + (ts,i) <- readSTM + let + ((count,id),next) = case Map.lookup t ts of + Just (nu,id) -> ((nu+1,id), i) + _ -> ((1, i ), i+1) + writeSTM (Map.insert t (count,id) ts, next) + diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs new file mode 100644 index 000000000..787433963 --- /dev/null +++ b/src/compiler/GF/Compile/PGFtoHaskell.hs @@ -0,0 +1,230 @@ +---------------------------------------------------------------------- +-- | +-- Module : PGFtoHaskell +-- Maintainer : Aarne Ranta +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/06/17 12:39:07 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.8 $ +-- +-- to write a GF abstract grammar into a Haskell module with translations from +-- data objects into GF trees. Example: GSyntax for Agda. +-- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004 +----------------------------------------------------------------------------- + +module GF.Compile.PGFtoHaskell (grammar2haskell) where + +import PGF.CId +import PGF.Data +import PGF.Macros + +import GF.Data.Operations +import GF.Infra.Option +import GF.Text.UTF8 + +import Data.List --(isPrefixOf, find, intersperse) +import qualified Data.Map as Map + +type Prefix = String -> String + +-- | the main function +grammar2haskell :: Options + -> String -- ^ Module name. + -> PGF + -> String +grammar2haskell opts name gr = encodeUTF8 $ foldr (++++) [] $ + pragmas ++ haskPreamble name ++ [types, gfinstances gId lexical gr'] + where gr' = hSkeleton gr + gadt = haskellOption opts HaskellGADT + lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat + gId | haskellOption opts HaskellNoPrefix = id + | otherwise = ("G"++) + pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}"] + | otherwise = [] + types | gadt = datatypesGADT gId lexical gr' + | otherwise = datatypes gId lexical gr' + +haskPreamble name = + [ + "module " ++ name ++ " where", + "", + "import PGF", + "----------------------------------------------------", + "-- automatic translation from GF to Haskell", + "----------------------------------------------------", + "", + "class Gf a where", + " gf :: a -> Tree", + " fg :: Tree -> a", + "", + predefInst "GString" "String" "unStr" "mkStr", + "", + predefInst "GInt" "Integer" "unInt" "mkInt", + "", + predefInst "GFloat" "Double" "unDouble" "mkDouble", + "", + "----------------------------------------------------", + "-- below this line machine-generated", + "----------------------------------------------------", + "" + ] + +predefInst gtyp typ destr consr = + "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++ + "instance Gf" +++ gtyp +++ "where" ++++ + " gf (" ++ gtyp +++ "x) =" +++ consr +++ "x" ++++ + " fg t =" ++++ + " case "++destr++" t of" ++++ + " Just x -> " +++ gtyp +++ "x" ++++ + " Nothing -> error (\"no" +++ gtyp +++ "\" ++ show t)" + +type OIdent = String + +type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] + +datatypes :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String +datatypes gId lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId lexical)) . snd + +gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String +gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g + + +hDatatype :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String +hDatatype _ _ ("Cn",_) = "" --- +hDatatype _ _ (cat,[]) = "" +hDatatype gId _ (cat,rules) | isListCat (cat,rules) = + "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" + +++ "deriving Show" +hDatatype gId lexical (cat,rules) = + "data" +++ gId cat +++ "=" ++ + (if length rules == 1 then "" else "\n ") +++ + foldr1 (\x y -> x ++ "\n |" +++ y) constructors ++++ + " deriving Show" + where + constructors = [gId f +++ foldr (+++) "" (map (gId) xx) | (f,xx) <- nonLexicalRules (lexical cat) rules] + ++ if lexical cat then [lexicalConstructor cat +++ "String"] else [] + +nonLexicalRules :: Bool -> [(OIdent, [OIdent])] -> [(OIdent, [OIdent])] +nonLexicalRules False rules = rules +nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)] + +lexicalConstructor :: OIdent -> String +lexicalConstructor cat = "Lex" ++ cat + +-- GADT version of data types +datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String +datatypesGADT gId lexical (_,skel) = + unlines (concatMap (hCatTypeGADT gId) skel) + +++++ + "data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT gId lexical) skel) + +hCatTypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String] +hCatTypeGADT gId (cat,rules) + = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_", + "data"+++gId cat++"_"] + +hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String] +hDatatypeGADT gId lexical (cat, rules) + | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t] + | otherwise = + [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t + | (f,args) <- nonLexicalRules (lexical cat) rules ] + ++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else [] + where t = "Tree" +++ gId cat ++ "_" + +gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String +gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs + +----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004 +hInstance _ _ m (cat,[]) = "" +hInstance gId lexical m (cat,rules) + | isListCat (cat,rules) = + "instance Gf" +++ gId cat +++ "where" ++++ + " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" + +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++ + " gf (" ++ gId cat +++ "(x:xs)) = " + ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] +-- no show for GADTs +-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" + | otherwise = + "instance Gf" +++ gId cat +++ "where\n" ++ + unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] + ++ if lexical cat then [" gf (" ++ lexicalConstructor cat +++ "x) = mkApp (mkCId x) []"] else []) + where + ec = elemCat cat + baseVars = mkVars (baseSize (cat,rules)) + mkInst f xx = let xx' = mkVars (length xx) in " gf " ++ + (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++ + "=" +++ mkRHS f xx' + mkVars n = ["x" ++ show i | i <- [1..n]] + mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++ + "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" + + +----fInstance m ("Cn",_) = "" --- +fInstance _ _ m (cat,[]) = "" +fInstance gId lexical m (cat,rules) = + " fg t =" ++++ + " case unApp t of" ++++ + unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++ + (if lexical cat then " (i,[]) -> " ++ lexicalConstructor cat +++ "(prCId i)" else "") ++++ + " _ -> error (\"no" +++ cat ++ " \" ++ show t)" + where + mkInst f xx = + " Just (i," ++ + "[" ++ prTList "," xx' ++ "])" +++ + "| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx' + where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]] + mkRHS f vars + | isListCat (cat,rules) = + if "Base" `isPrefixOf` f then + gId cat +++ "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]" + else + let (i,t) = (init vars,last vars) + in "let" +++ gId cat +++ "xs = fg " ++ t +++ "in" +++ + gId cat +++ prParenth (prTList ":" (["fg"+++v | v <- i] ++ ["xs"])) + | otherwise = + gId f +++ + prTList " " [prParenth ("fg" +++ x) | x <- vars] + + +--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] +hSkeleton :: PGF -> (String,HSkeleton) +hSkeleton gr = + (showCId (absname gr), + [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) | + fs@((_, (_,c)):_) <- fns] + ) + where + fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr))))) + valtyps (_, (_,x)) (_, (_,y)) = compare x y + valtypg (_, (_,x)) (_, (_,y)) = x == y + jty (f,(ty,_,_)) = (f,catSkeleton ty) + +updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton +updateSkeleton cat skel rule = + case skel of + (cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr + (cat0,rules):rr -> (cat0, rules) : updateSkeleton cat rr rule + +isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool +isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2 + && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs + where c = elemCat cat + fs = map fst rules + +-- | Gets the element category of a list category. +elemCat :: OIdent -> OIdent +elemCat = drop 4 + +isBaseFun :: OIdent -> Bool +isBaseFun f = "Base" `isPrefixOf` f + +isConsFun :: OIdent -> Bool +isConsFun f = "Cons" `isPrefixOf` f + +baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int +baseSize (_,rules) = length bs + where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules diff --git a/src/compiler/GF/Compile/PGFtoJS.hs b/src/compiler/GF/Compile/PGFtoJS.hs new file mode 100644 index 000000000..ff75d8fe6 --- /dev/null +++ b/src/compiler/GF/Compile/PGFtoJS.hs @@ -0,0 +1,122 @@ +module GF.Compile.PGFtoJS (pgf2js) where + +import PGF.CId +import PGF.Data hiding (mkStr) +import qualified PGF.Macros as M +import qualified GF.JavaScript.AbsJS as JS +import qualified GF.JavaScript.PrintJS as JS + +import GF.Text.UTF8 +import GF.Data.ErrM +import GF.Infra.Option + +import Control.Monad (mplus) +import Data.Array.Unboxed (UArray) +import qualified Data.Array.IArray as Array +import Data.Maybe (fromMaybe) +import Data.Map (Map) +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap + +pgf2js :: PGF -> String +pgf2js pgf = + encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]] + where + n = showCId $ absname pgf + as = abstract pgf + cs = Map.assocs (concretes pgf) + start = showCId $ M.lookStartCat pgf + grammar = new "GFGrammar" [js_abstract, js_concrete] + js_abstract = abstract2js start as + js_concrete = JS.EObj $ map (concrete2js n) cs + +abstract2js :: String -> Abstr -> JS.Expr +abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))] + +absdef2js :: (CId,(Type,Int,[Equation])) -> JS.Property +absdef2js (f,(typ,_,_)) = + let (args,cat) = M.catSkeleton typ in + JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)]) + +concrete2js :: String -> (CId,Concr) -> JS.Property +concrete2js n (c, cnc) = + JS.Prop l (new "GFConcrete" ([flags,(JS.EObj $ ((map (cncdef2js n (showCId c)) ds) ++ litslins))] ++ + maybe [] parser2js (parser cnc))) + where + flags = mapToJSObj JS.EStr $ cflags cnc + l = JS.IdentPropName (JS.Ident (showCId c)) + ds = concatMap Map.assocs [lins cnc, opers cnc, lindefs cnc] + litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), + JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), + JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])] + + +cncdef2js :: String -> String -> (CId,Term) -> JS.Property +cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)]) + +term2js :: String -> String -> Term -> JS.Expr +term2js n l t = f t + where + f t = + case t of + R xs -> new "Arr" (map f xs) + P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y] + S xs -> mkSeq (map f xs) + K t -> tokn2js t + V i -> JS.EIndex (JS.EVar children) (JS.EInt i) + C i -> new "Int" [JS.EInt i] + F f -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr (showCId f), JS.EVar children] + FV xs -> new "Variants" (map f xs) + W str x -> new "Suffix" [JS.EStr str, f x] + TM _ -> new "Meta" [] + +tokn2js :: Tokn -> JS.Expr +tokn2js (KS s) = mkStr s +tokn2js (KP ss vs) = mkSeq (map mkStr ss) -- FIXME + +mkStr :: String -> JS.Expr +mkStr s = new "Str" [JS.EStr s] + +mkSeq :: [JS.Expr] -> JS.Expr +mkSeq [x] = x +mkSeq xs = new "Seq" xs + +argIdent :: Integer -> JS.Ident +argIdent n = JS.Ident ("x" ++ show n) + +children :: JS.Ident +children = JS.Ident "cs" + +-- Parser +parser2js :: ParserInfo -> [JS.Expr] +parser2js p = [new "Parser" [JS.EObj $ [JS.Prop (JS.IntPropName cat) (JS.EArray (map frule2js (Set.toList set))) | (cat,set) <- IntMap.toList (productions0 p)], + JS.EArray $ (map ffun2js (Array.elems (functions p))), + JS.EArray $ (map seq2js (Array.elems (sequences p))), + JS.EObj $ map cats (Map.assocs (startCats p)), + JS.EInt (totalCats p)]] + where + cats (c,is) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EArray (map JS.EInt is)) + +frule2js :: Production -> JS.Expr +frule2js (FApply funid args) = new "Rule" [JS.EInt funid, JS.EArray (map JS.EInt args)] +frule2js (FCoerce arg) = new "Coerce" [JS.EInt arg] + +ffun2js (FFun f _ lins) = new "FFun" [JS.EStr (showCId f), JS.EArray (map JS.EInt (Array.elems lins))] + +seq2js :: Array.Array FIndex FSymbol -> JS.Expr +seq2js seq = JS.EArray [sym2js s | s <- Array.elems seq] + +sym2js :: FSymbol -> JS.Expr +sym2js (FSymCat n l) = new "Arg" [JS.EInt n, JS.EInt l] +sym2js (FSymLit n l) = new "Lit" [JS.EInt n, JS.EInt l] +sym2js (FSymKS ts) = new "KS" (map JS.EStr ts) +sym2js (FSymKP ts alts) = new "KP" [JS.EArray (map JS.EStr ts), JS.EArray (map alt2js alts)] + +alt2js (Alt ps ts) = new "Alt" [JS.EArray (map JS.EStr ps), JS.EArray (map JS.EStr ts)] + +new :: String -> [JS.Expr] -> JS.Expr +new f xs = JS.ENew (JS.Ident f) xs + +mapToJSObj :: (a -> JS.Expr) -> Map CId a -> JS.Expr +mapToJSObj f m = JS.EObj [ JS.Prop (JS.IdentPropName (JS.Ident (showCId k))) (f v) | (k,v) <- Map.toList m ] diff --git a/src/compiler/GF/Compile/PGFtoProlog.hs b/src/compiler/GF/Compile/PGFtoProlog.hs new file mode 100644 index 000000000..538430747 --- /dev/null +++ b/src/compiler/GF/Compile/PGFtoProlog.hs @@ -0,0 +1,279 @@ +---------------------------------------------------------------------- +-- | +-- Module : PGFtoProlog +-- Maintainer : Peter Ljunglöf +-- Stability : (stable) +-- Portability : (portable) +-- +-- to write a GF grammar into a Prolog module +----------------------------------------------------------------------------- + +module GF.Compile.PGFtoProlog (grammar2prolog, grammar2prolog_abs) where + +import PGF.CId +import PGF.Data +import PGF.Macros + +import GF.Data.Operations +import GF.Text.UTF8 + +import qualified Data.Map as Map +import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper, ord) +import Data.List (isPrefixOf,mapAccumL) + +grammar2prolog, grammar2prolog_abs :: PGF -> String +-- Most prologs have problems with UTF8 encodings, so we skip that: +grammar2prolog = {- encodeUTF8 . -} foldr (++++) [] . pgf2clauses +grammar2prolog_abs = {- encodeUTF8 . -} foldr (++++) [] . pgf2clauses_abs + + +pgf2clauses :: PGF -> [String] +pgf2clauses (PGF absname cncnames gflags abstract concretes) = + [":- " ++ plFact "module" [plp absname, "[]"]] ++ + clauseHeader "%% concrete(?Module)" + [plFact "concrete" [plp cncname] | cncname <- cncnames] ++ + clauseHeader "%% flag(?Flag, ?Value): global flags" + (map (plpFact2 "flag") (Map.assocs gflags)) ++ + plAbstract (absname, abstract) ++ + concatMap plConcrete (Map.assocs concretes) + +pgf2clauses_abs :: PGF -> [String] +pgf2clauses_abs (PGF absname _cncnames gflags abstract _concretes) = + [":- " ++ plFact "module" [plp absname, "[]"]] ++ + clauseHeader "%% flag(?Flag, ?Value): global flags" + (map (plpFact2 "flag") (Map.assocs gflags)) ++ + plAbstract (absname, abstract) + +clauseHeader :: String -> [String] -> [String] +clauseHeader hdr [] = [] +clauseHeader hdr clauses = "":hdr:clauses + + +---------------------------------------------------------------------- +-- abstract syntax + +plAbstract :: (CId, Abstr) -> [String] +plAbstract (name, Abstr aflags funs cats _catfuns) = + ["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%", + "%% abstract module: " ++ plp name] ++ + clauseHeader "%% absflag(?Flag, ?Value): flags for abstract syntax" + (map (plpFact2 "absflag") (Map.assocs aflags)) ++ + clauseHeader "%% cat(?Type, ?[X:Type,...])" + (map plCat (Map.assocs cats)) ++ + clauseHeader "%% fun(?Fun, ?Type, ?[X:Type,...])" + (map plFun (Map.assocs funs)) ++ + clauseHeader "%% def(?Fun, ?Expr)" + (concatMap plFundef (Map.assocs funs)) + +plCat :: (CId, [Hypo]) -> String +plCat (cat, hypos) = plFact "cat" (plTypeWithHypos typ) + where ((_,subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos + args = reverse [EFun x | (_,x) <- subst] + typ = DTyp hypos' cat args + +plFun :: (CId, (Type, Int, [Equation])) -> String +plFun (fun, (typ,_,_)) = plFact "fun" (plp fun : plTypeWithHypos typ') + where typ' = snd $ alphaConvert emptyEnv typ + +plTypeWithHypos :: Type -> [String] +plTypeWithHypos (DTyp hypos cat args) = [plTerm (plp cat) (map plp args), plList (map (\(_,x,ty) -> plOper ":" (plp x) (plp ty)) hypos)] + +plFundef :: (CId, (Type,Int,[Equation])) -> [String] +plFundef (fun, (_,_,[])) = [] +plFundef (fun, (_,_,eqs)) = [plFact "def" [plp fun, plp fundef']] + where fundef' = snd $ alphaConvert emptyEnv eqs + + +---------------------------------------------------------------------- +-- concrete syntax + +plConcrete :: (CId, Concr) -> [String] +plConcrete (cncname, Concr cflags lins opers lincats lindefs + _printnames _paramlincats _parser) = + ["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%", + "%% concrete module: " ++ plp cncname] ++ + clauseHeader "%% cncflag(?Flag, ?Value): flags for concrete syntax" + (map (mod . plpFact2 "cncflag") (Map.assocs cflags)) ++ + clauseHeader "%% lincat(?Cat, ?Linearization type)" + (map (mod . plpFact2 "lincat") (Map.assocs lincats)) ++ + clauseHeader "%% lindef(?Cat, ?Linearization default)" + (map (mod . plpFact2 "lindef") (Map.assocs lindefs)) ++ + clauseHeader "%% lin(?Fun, ?Linearization)" + (map (mod . plpFact2 "lin") (Map.assocs lins)) ++ + clauseHeader "%% oper(?Oper, ?Linearization)" + (map (mod . plpFact2 "oper") (Map.assocs opers)) + where mod clause = plp cncname ++ ": " ++ clause + + +---------------------------------------------------------------------- +-- prolog-printing pgf datatypes + +instance PLPrint Type where + plp (DTyp hypos cat args) | null hypos = result + | otherwise = plOper " -> " (plList (map (\(_,x,ty) -> plOper ":" (plp x) (plp ty)) hypos)) result + where result = plTerm (plp cat) (map plp args) + +instance PLPrint Expr where + plp (EFun x) = plp x + plp (EAbs _ x e)= plOper "^" (plp x) (plp e) + plp (EApp e e') = plOper " * " (plp e) (plp e') + plp (ELit lit) = plp lit + plp (EMeta n) = "Meta_" ++ show n + +instance PLPrint Patt where + plp (PVar x) = plp x + plp (PApp f ps) = plOper " * " (plp f) (plp ps) + plp (PLit lit) = plp lit + +instance PLPrint Equation where + plp (Equ patterns result) = plOper ":" (plp patterns) (plp result) + +instance PLPrint Term where + plp (S terms) = plTerm "s" [plp terms] + plp (C n) = plTerm "c" [show n] + plp (K tokn) = plTerm "k" [plp tokn] + plp (FV trms) = plTerm "fv" [plp trms] + plp (P t1 t2) = plTerm "p" [plp t1, plp t2] + plp (W s trm) = plTerm "w" [plp s, plp trm] + plp (R terms) = plTerm "r" [plp terms] + plp (F oper) = plTerm "f" [plp oper] + plp (V n) = plTerm "v" [show n] + plp (TM str) = plTerm "tm" [plp str] + +{-- more prolog-like syntax for PGF terms, but also more difficult to handle: +instance PLPrint Term where + plp (S terms) = plp terms + plp (C n) = show n + plp (K token) = plp token + plp (FV terms) = prCurlyList (map plp terms) + plp (P t1 t2) = plOper "/" (plp t1) (plp t2) + plp (W s trm) = plOper "+" (plp s) (plp trm) + plp (R terms) = plTerm "r" (map plp terms) + plp (F oper) = plTerm "f" [plp oper] + plp (V n) = plTerm "arg" [show n] + plp (TM str) = plTerm "meta" [plp str] +--} + +instance PLPrint CId where + plp cid | isLogicalVariable str || + cid == wildCId = plVar str + | otherwise = plAtom str + where str = showCId cid + +instance PLPrint Literal where + plp (LStr s) = plp s + plp (LInt n) = plp (show n) + plp (LFlt f) = plp (show f) + +instance PLPrint Tokn where + plp (KS tokn) = plp tokn + plp (KP strs alts) = plTerm "kp" [plp strs, plList [plOper "/" (plp ss1) (plp ss2) | + Alt ss1 ss2 <- alts]] + +---------------------------------------------------------------------- +-- basic prolog-printing + +class PLPrint a where + plp :: a -> String + plps :: [a] -> String + plps = plList . map plp + +instance PLPrint Char where + plp c = plAtom [c] + plps s = plAtom s + +instance PLPrint a => PLPrint [a] where + plp = plps + +plpFact2 :: (PLPrint a, PLPrint b) => String -> (a, b) -> String +plpFact2 fun (arg1, arg2) = plFact fun [plp arg1, plp arg2] + +plFact :: String -> [String] -> String +plFact fun args = plTerm fun args ++ "." + +plTerm :: String -> [String] -> String +plTerm fun args = plAtom fun ++ prParenth (prTList ", " args) + +plList :: [String] -> String +plList = prBracket . prTList "," + +plOper :: String -> String -> String -> String +plOper op a b = prParenth (a ++ op ++ b) + +plVar :: String -> String +plVar = varPrefix . concatMap changeNonAlphaNum + where varPrefix var@(c:_) | isAsciiUpper c || c=='_' = var + | otherwise = "_" ++ var + changeNonAlphaNum c | isAlphaNumUnderscore c = [c] + | otherwise = "_" ++ show (ord c) ++ "_" + +plAtom :: String -> String +plAtom "" = "''" +plAtom atom@(c:cs) | isAsciiLower c && all isAlphaNumUnderscore cs + || c == '\'' && cs /= "" && last cs == '\'' = atom + | otherwise = "'" ++ concatMap changeQuote atom ++ "'" + where changeQuote '\'' = "\\'" + changeQuote c = [c] + +isAlphaNumUnderscore :: Char -> Bool +isAlphaNumUnderscore c = isAlphaNum c || c == '_' + + +---------------------------------------------------------------------- +-- prolog variables + +createLogicalVariable :: Int -> CId +createLogicalVariable n = mkCId (logicalVariablePrefix ++ show n) + +isLogicalVariable :: String -> Bool +isLogicalVariable = isPrefixOf logicalVariablePrefix + +logicalVariablePrefix :: String +logicalVariablePrefix = "X" + +---------------------------------------------------------------------- +-- alpha convert variables to (unique) logical variables +-- * this is needed if we want to translate variables to Prolog variables +-- * used for abstract syntax, not concrete +-- * not (yet?) used for variables bound in pattern equations + +type ConvertEnv = (Int, [(CId,CId)]) + +emptyEnv :: ConvertEnv +emptyEnv = (0, []) + +class AlphaConvert a where + alphaConvert :: ConvertEnv -> a -> (ConvertEnv, a) + +instance AlphaConvert a => AlphaConvert [a] where + alphaConvert env [] = (env, []) + alphaConvert env (a:as) = (env'', a':as') + where (env', a') = alphaConvert env a + (env'', as') = alphaConvert env' as + +instance AlphaConvert Type where + alphaConvert env@(_,subst) (DTyp hypos cat args) + = ((ctr,subst), DTyp hypos' cat args') + where (env', hypos') = mapAccumL alphaConvertHypo env hypos + ((ctr,_), args') = alphaConvert env' args + +alphaConvertHypo env (b,x,typ) = ((ctr+1,(x,x'):subst), (b,x',typ')) + where ((ctr,subst), typ') = alphaConvert env typ + x' = createLogicalVariable ctr + +instance AlphaConvert Expr where + alphaConvert (ctr,subst) (EAbs b x e) = ((ctr',subst), EAbs b x' e') + where ((ctr',_), e') = alphaConvert (ctr+1,(x,x'):subst) e + x' = createLogicalVariable ctr + alphaConvert env (EApp e1 e2) = (env'', EApp e1' e2') + where (env', e1') = alphaConvert env e1 + (env'', e2') = alphaConvert env' e2 + alphaConvert env expr@(EFun i) = (env, maybe expr EFun (lookup i (snd env))) + alphaConvert env expr = (env, expr) + +-- pattern variables are not alpha converted +-- (but they probably should be...) +instance AlphaConvert Equation where + alphaConvert env@(_,subst) (Equ patterns result) + = ((ctr,subst), Equ patterns result') + where ((ctr,_), result') = alphaConvert env result -- cgit v1.2.3