summaryrefslogtreecommitdiff
path: root/src/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler')
-rw-r--r--src/compiler/GF/Compile/ConcreteToCanonical.hs60
-rw-r--r--src/compiler/GF/Compile/ConcreteToHaskell.hs5
-rw-r--r--src/compiler/GF/Compile/Export.hs7
-rw-r--r--src/compiler/GF/Compiler.hs17
-rw-r--r--src/compiler/GF/Grammar/Canonical.hs37
5 files changed, 100 insertions, 26 deletions
diff --git a/src/compiler/GF/Compile/ConcreteToCanonical.hs b/src/compiler/GF/Compile/ConcreteToCanonical.hs
index 5208fd005..7422b6205 100644
--- a/src/compiler/GF/Compile/ConcreteToCanonical.hs
+++ b/src/compiler/GF/Compile/ConcreteToCanonical.hs
@@ -1,25 +1,57 @@
--- | Translate concrete syntax to canonical form
-module GF.Compile.ConcreteToCanonical(concretes2canonical) where
-import Data.List(nub,sort,sortBy,partition)
---import Data.Function(on)
+-- | Translate grammars to Canonical form
+-- (a common intermediate representation to simplify export to other formats)
+module GF.Compile.ConcreteToCanonical(grammar2canonical,abstract2canonical,concretes2canonical) where
+import Data.List(nub,partition)
import qualified Data.Map as M
import qualified Data.Set as S
import GF.Data.ErrM
-import GF.Data.Utilities(mapSnd)
import GF.Text.Pretty
import GF.Grammar.Grammar
-import GF.Grammar.Lookup(lookupFunType,lookupOrigInfo,allOrigInfos,allParamValues)
+import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt)
import GF.Grammar.Lockfield(isLockLabel)
import GF.Grammar.Predef(cPredef,cInts)
import GF.Compile.Compute.Predef(predef)
import GF.Compile.Compute.Value(Predefined(..))
-import GF.Infra.Ident(ModuleName(..),Ident,identS,prefixIdent,showIdent,isWildIdent) --,moduleNameS
---import GF.Infra.Option
+import GF.Infra.Ident(ModuleName(..),Ident,identS,prefixIdent,showIdent,isWildIdent)
+import GF.Infra.Option(optionsPGF)
+import PGF.Internal(Literal(..))
import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
import GF.Grammar.Canonical as C
import Debug.Trace
+-- | Generate Canonical code for the named abstract syntax and all associated
+-- concrete syntaxes
+grammar2canonical opts absname gr =
+ Grammar (abstract2canonical absname gr)
+ (map snd (concretes2canonical opts absname gr))
+
+-- | Generate Canonical code for the named abstract syntax
+abstract2canonical absname gr =
+ Abstract (modId absname) (convFlags gr absname) cats funs
+ where
+ cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs]
+
+ funs = [FunDef (gId f) (convType ty) |
+ ((_,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs]
+
+ adefs = allOrigInfos gr absname
+
+ convCtx = maybe [] (map convHypo . unLoc)
+ convHypo (bt,name,t) =
+ case typeForm t of
+ ([],(_,cat),[]) -> gId cat -- !!
+
+ convType t =
+ case typeForm t of
+ (hyps,(_,cat),args) -> Type bs (TypeApp (gId cat) as)
+ where
+ bs = map convHypo' hyps
+ as = map convType args
+
+ convHypo' (bt,name,t) = TypeBinding (gId name) (convType t)
+
+
-- | Generate Canonical code for the all concrete syntaxes associated with
-- the named abstract syntax in given the grammar.
concretes2canonical opts absname gr =
@@ -34,7 +66,7 @@ concretes2canonical opts absname gr =
-- The only options that make a difference are
-- @-haskell=noprefix@ and @-haskell=variants@.
concrete2canonical opts gr cenv absname cnc modinfo =
- Concrete (modId cnc) (modId absname)
+ Concrete (modId cnc) (modId absname) (convFlags gr cnc)
(neededParamTypes S.empty (params defs))
[lincat|(_,Left lincat)<-defs]
[lin|(_,Right lin)<-defs]
@@ -402,3 +434,13 @@ instance FromIdent C.FunId where gId = C.FunId . showIdent
instance FromIdent CatId where gId = CatId . showIdent
instance FromIdent ParamId where gId = ParamId . showIdent
instance FromIdent VarValueId where gId = VarValueId . showIdent
+
+convFlags gr mn =
+ Flags [(n,convLit v) |
+ (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
+ where
+ convLit l =
+ case l of
+ LStr s -> Str s
+ LInt i -> C.Int i
+ LFlt d -> Flt d
diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs
index ad4775697..fc5c689fc 100644
--- a/src/compiler/GF/Compile/ConcreteToHaskell.hs
+++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs
@@ -18,6 +18,8 @@ import GF.Infra.Ident(Ident,identS,prefixIdent) --,moduleNameS
import GF.Infra.Option
import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
import GF.Haskell
+--import GF.Grammar.Canonical
+--import GF.Compile.ConcreteToCanonical
import Debug.Trace
-- | Generate Haskell code for the all concrete syntaxes associated with
@@ -28,6 +30,9 @@ concretes2haskell opts absname gr =
cnc<-allConcretes gr absname,
let cncname = render cnc ++ ".hs" :: FilePath
Ok cncmod = lookupModule gr cnc
+{- (_,cnc)<-concretes2canonical opt absname gr,
+ let ModId name = concName cnc
+ cncname = name ++ ".hs" :: FilePath--}
]
-- | Generate Haskell code for the given concrete module.
diff --git a/src/compiler/GF/Compile/Export.hs b/src/compiler/GF/Compile/Export.hs
index 5403298f9..c86c9dd03 100644
--- a/src/compiler/GF/Compile/Export.hs
+++ b/src/compiler/GF/Compile/Export.hs
@@ -3,7 +3,7 @@ module GF.Compile.Export where
import PGF
import PGF.Internal(ppPGF)
import GF.Compile.PGFtoHaskell
-import GF.Compile.PGFtoAbstract
+--import GF.Compile.PGFtoAbstract
import GF.Compile.PGFtoJava
import GF.Compile.PGFtoProlog
import GF.Compile.PGFtoJS
@@ -35,7 +35,7 @@ exportPGF :: Options
exportPGF opts fmt pgf =
case fmt of
FmtPGFPretty -> multi "txt" (render . ppPGF)
- FmtCanonicalGF -> canon "gf" (render80 . abstract2canonical)
+ FmtCanonicalGF -> [] -- canon "gf" (render80 . abstract2canonical)
FmtJavaScript -> multi "js" pgf2js
FmtPython -> multi "py" pgf2python
FmtHaskell -> multi "hs" (grammar2haskell opts name)
@@ -58,7 +58,8 @@ exportPGF opts fmt pgf =
multi :: String -> (PGF -> String) -> [(FilePath,String)]
multi ext pr = [(name <.> ext, pr pgf)]
- canon ext pr = [("canonical"</>name<.>ext,pr pgf)]
+
+-- canon ext pr = [("canonical"</>name<.>ext,pr pgf)]
single :: String -> (PGF -> CId -> String) -> [(FilePath,String)]
single ext pr = [(showCId cnc <.> ext, pr pgf cnc) | cnc <- languages pgf]
diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs
index 334bbd592..2bd0fc0cb 100644
--- a/src/compiler/GF/Compiler.hs
+++ b/src/compiler/GF/Compiler.hs
@@ -7,7 +7,7 @@ import GF.Compile as S(batchCompile,link,srcAbsName)
import GF.CompileInParallel as P(parallelBatchCompile)
import GF.Compile.Export
import GF.Compile.ConcreteToHaskell(concretes2haskell)
-import GF.Compile.ConcreteToCanonical(concretes2canonical)
+import GF.Compile.ConcreteToCanonical--(concretes2canonical)
import GF.Compile.CFGtoPGF
import GF.Compile.GetGrammar
import GF.Grammar.BNFC
@@ -60,17 +60,24 @@ compileSourceFiles opts fs =
do when (FmtHaskell `elem` ofmts && haskellOption opts HaskellConcrete) $
mapM_ cnc2haskell (snd output)
when (FmtCanonicalGF `elem` ofmts) $
- mapM_ cnc2canonical (snd output)
+ do createDirectoryIfMissing False "canonical"
+ mapM_ abs2canonical (snd output)
+ mapM_ cnc2canonical (snd output)
where
ofmts = flag optOutputFormats opts
cnc2haskell (cnc,gr) =
do mapM_ writeExport $ concretes2haskell opts (srcAbsName gr cnc) gr
+ abs2canonical (cnc,gr) =
+ writeExport ("canonical/"++render absname++".gf",render80 canAbs)
+ where
+ absname = srcAbsName gr cnc
+ canAbs = abstract2canonical absname gr
+
cnc2canonical (cnc,gr) =
- do createDirectoryIfMissing False "canonical"
- mapM_ (writeExport.fmap render80) $
- concretes2canonical opts (srcAbsName gr cnc) gr
+ mapM_ (writeExport.fmap render80) $
+ concretes2canonical opts (srcAbsName gr cnc) gr
writeExport (path,s) = writing opts path $ writeUTF8File path s
diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs
index 8d61a8a53..6d08b815f 100644
--- a/src/compiler/GF/Grammar/Canonical.hs
+++ b/src/compiler/GF/Grammar/Canonical.hs
@@ -1,6 +1,7 @@
-- | Abstract syntax for canonical GF grammars, i.e. what's left after
-- high-level constructions such as functors and opers have been eliminated
--- by partial evaluation.
+-- by partial evaluation. This is intended as a common intermediate
+-- representation to simplify export to other formats.
module GF.Grammar.Canonical where
import Prelude hiding ((<>))
import GF.Text.Pretty
@@ -12,7 +13,7 @@ data Grammar = Grammar Abstract [Concrete] deriving Show
-- ** Abstract Syntax
-- | Abstract Syntax
-data Abstract = Abstract ModId [CatDef] [FunDef] deriving Show
+data Abstract = Abstract ModId Flags [CatDef] [FunDef] deriving Show
data CatDef = CatDef CatId [CatId] deriving Show
data FunDef = FunDef FunId Type deriving Show
@@ -25,8 +26,9 @@ data TypeBinding = TypeBinding VarId Type deriving Show
-- ** Concreate syntax
-- | Concrete Syntax
-data Concrete = Concrete ModId ModId [ParamDef] [LincatDef] [LinDef]
+data Concrete = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef]
deriving Show
+concName (Concrete cnc _ _ _ _ _) = cnc
data ParamDef = ParamDef ParamId [ParamValueDef]
| ParamAliasDef ParamId LinType
@@ -99,6 +101,10 @@ newtype FunId = FunId String deriving (Eq,Show)
data VarId = Anonymous | VarId String deriving Show
+newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
+type FlagName = String
+data FlagValue = Str String | Int Int | Flt Double deriving Show
+
--------------------------------------------------------------------------------
-- ** Pretty printing
@@ -106,10 +112,12 @@ instance Pretty Grammar where
pp (Grammar abs cncs) = abs $+$ vcat cncs
instance Pretty Abstract where
- pp (Abstract m cats funs) = "abstract" <+> m <+> "=" <+> "{" $$
- "cat" <+> fsep cats $$
- "fun" <+> vcat funs $$
- "}"
+ pp (Abstract m flags cats funs) =
+ "abstract" <+> m <+> "=" <+> "{" $$
+ flags $$
+ "cat" <+> fsep cats $$
+ "fun" <+> vcat funs $$
+ "}"
instance Pretty CatDef where
pp (CatDef c cs) = hsep (c:cs)<>";"
@@ -139,7 +147,7 @@ instance Pretty VarId where
--------------------------------------------------------------------------------
instance Pretty Concrete where
- pp (Concrete cncid absid params lincats lins) =
+ pp (Concrete cncid absid flags params lincats lins) =
"concrete" <+> cncid <+> "of" <+> absid <+> "=" <+> "{" $$
vcat params $$
section "lincat" lincats $$
@@ -241,6 +249,17 @@ instance Pretty ParamId where pp = ppA
instance PPA ParamId where ppA (ParamId s) = pp s
instance Pretty VarValueId where pp (VarValueId s) = pp s
+instance Pretty Flags where
+ pp (Flags []) = empty
+ pp (Flags flags) = "flags" <+> vcat (map ppFlag flags)
+ where
+ ppFlag (name,value) = name <+> "=" <+> value <>";"
+
+instance Pretty FlagValue where
+ pp (Str s) = pp s
+ pp (Int i) = pp i
+ pp (Flt d) = pp d
+
--------------------------------------------------------------------------------
-- | Pretty print atomically (i.e. wrap it in parentheses if necessary)
class Pretty a => PPA a where ppA :: a -> Doc
@@ -248,4 +267,4 @@ class Pretty a => PPA a where ppA :: a -> Doc
class Pretty rhs => RhsSeparator rhs where rhsSep :: rhs -> Doc
semiSep xs = punctuate ";" xs
-block xs = braces (semiSep xs) \ No newline at end of file
+block xs = braces (semiSep xs)
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 07:31:10 +0000