mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-08 10:42:50 -06:00
3814841d7d
+ References to modules under src/compiler have been eliminated from the PGF library (under src/runtime/haskell). Only two functions had to be moved (from GF.Data.Utilities to PGF.Utilities) to make this possible, other apparent dependencies turned out to be vacuous. + In gf.cabal, the GF executable no longer directly depends on the PGF library source directory, but only on the exposed library modules. This means that there is less duplication in gf.cabal and that the 30 modules in the PGF library will no longer be compiled twice while building GF. To make this possible, additional PGF library modules have been exposed, even though they should probably be considered for internal use only. They could be collected in a PGF.Internal module, or marked as "unstable", to make this explicit. + Also, by using the -fwarn-unused-imports flag, ~220 redundant imports were found and removed, reducing the total number of imports by ~15%.
115 lines
4.6 KiB
Haskell
115 lines
4.6 KiB
Haskell
module PGF.Printer (ppPGF,ppCat,ppFId,ppFunId,ppSeqId,ppSeq,ppFun) where
|
|
|
|
import PGF.CId
|
|
import PGF.Data
|
|
--import PGF.Macros
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import qualified Data.IntMap as IntMap
|
|
import Data.List
|
|
import Data.Array.IArray
|
|
--import Data.Array.Unboxed
|
|
import Text.PrettyPrint
|
|
|
|
|
|
ppPGF :: PGF -> Doc
|
|
ppPGF pgf = ppAbs (absname pgf) (abstract pgf) $$ ppAll ppCnc (concretes pgf)
|
|
|
|
ppAbs :: Language -> Abstr -> Doc
|
|
ppAbs name a = text "abstract" <+> ppCId name <+> char '{' $$
|
|
nest 2 (ppAll ppFlag (aflags a) $$
|
|
ppAll ppCat (cats a) $$
|
|
ppAll ppFun (funs a)) $$
|
|
char '}'
|
|
|
|
ppFlag :: CId -> Literal -> Doc
|
|
ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+> char ';'
|
|
|
|
ppCat :: CId -> ([Hypo],[(Double,CId)],BCAddr) -> Doc
|
|
ppCat c (hyps,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
|
|
|
|
ppFun :: CId -> (Type,Int,Maybe [Equation],Double,BCAddr) -> Doc
|
|
ppFun f (t,_,Just eqs,_,_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
|
|
if null eqs
|
|
then empty
|
|
else text "def" <+> vcat [let scope = foldl pattScope [] patts
|
|
ds = map (ppPatt 9 scope) patts
|
|
in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs]
|
|
ppFun f (t,_,Nothing,_,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
|
|
|
|
ppCnc :: Language -> Concr -> Doc
|
|
ppCnc name cnc =
|
|
text "concrete" <+> ppCId name <+> char '{' $$
|
|
nest 2 (ppAll ppFlag (cflags cnc) $$
|
|
text "productions" $$
|
|
nest 2 (vcat [ppProduction (fcat,prod) | (fcat,set) <- IntMap.toList (productions cnc), prod <- Set.toList set]) $$
|
|
text "lindefs" $$
|
|
nest 2 (vcat (map ppFunList (IntMap.toList (lindefs cnc)))) $$
|
|
text "linrefs" $$
|
|
nest 2 (vcat (map ppFunList (IntMap.toList (linrefs cnc)))) $$
|
|
text "lin" $$
|
|
nest 2 (vcat (map ppCncFun (assocs (cncfuns cnc)))) $$
|
|
text "sequences" $$
|
|
nest 2 (vcat (map ppSeq (assocs (sequences cnc)))) $$
|
|
text "categories" $$
|
|
nest 2 (vcat (map ppCncCat (Map.toList (cnccats cnc)))) $$
|
|
text "printnames" $$
|
|
nest 2 (vcat (map ppPrintName (Map.toList (printnames cnc))))) $$
|
|
char '}'
|
|
|
|
ppCncArg :: PArg -> Doc
|
|
ppCncArg (PArg hyps fid)
|
|
| null hyps = ppFId fid
|
|
| otherwise = hsep (map (ppFId . snd) hyps) <+> text "->" <+> ppFId fid
|
|
|
|
ppProduction (fid,PApply funid args) =
|
|
ppFId fid <+> text "->" <+> ppFunId funid <> brackets (hcat (punctuate comma (map ppCncArg args)))
|
|
ppProduction (fid,PCoerce arg) =
|
|
ppFId fid <+> text "->" <+> char '_' <> brackets (ppFId arg)
|
|
ppProduction (fid,PConst _ _ ss) =
|
|
ppFId fid <+> text "->" <+> ppStrs ss
|
|
|
|
ppCncFun (funid,CncFun fun arr) =
|
|
ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun)
|
|
|
|
ppFunList (fid,funids) =
|
|
ppFId fid <+> text "->" <+> hcat (punctuate comma (map ppFunId funids))
|
|
|
|
ppSeq (seqid,seq) =
|
|
ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol (elems seq))
|
|
|
|
ppCncCat (id,(CncCat start end labels)) =
|
|
ppCId id <+> text ":=" <+> (text "range " <+> brackets (ppFId start <+> text ".." <+> ppFId end) $$
|
|
text "labels" <+> brackets (vcat (map (text . show) (elems labels))))
|
|
|
|
ppPrintName (id,name) =
|
|
ppCId id <+> text ":=" <+> ppStrs [name]
|
|
|
|
ppSymbol (SymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
|
|
ppSymbol (SymLit d r) = char '{' <> int d <> comma <> int r <> char '}'
|
|
ppSymbol (SymVar d r) = char '<' <> int d <> comma <> char '$' <> int r <> char '>'
|
|
ppSymbol (SymKS t) = doubleQuotes (text t)
|
|
ppSymbol SymNE = text "nonExist"
|
|
ppSymbol SymBIND = text "BIND"
|
|
ppSymbol (SymKP syms alts) = text "pre" <+> braces (hsep (punctuate semi (hsep (map ppSymbol syms) : map ppAlt alts)))
|
|
|
|
ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> char '/' <+> hsep (map (doubleQuotes . text) ps)
|
|
|
|
ppStrs ss = doubleQuotes (hsep (map text ss))
|
|
|
|
ppFId fid
|
|
| fid == fidString = text "CString"
|
|
| fid == fidInt = text "CInt"
|
|
| fid == fidFloat = text "CFloat"
|
|
| fid == fidVar = text "CVar"
|
|
| otherwise = char 'C' <> int fid
|
|
|
|
ppFunId funid = char 'F' <> int funid
|
|
ppSeqId seqid = char 'S' <> int seqid
|
|
|
|
-- Utilities
|
|
|
|
ppAll :: (a -> b -> Doc) -> Map.Map a b -> Doc
|
|
ppAll p m = vcat [ p k v | (k,v) <- Map.toList m]
|