{-# LANGUAGE FlexibleContexts #-}
module PGF.Printer (ppPGF,ppCat,ppFId,ppFunId,ppSeqId,ppSeq,ppFun) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint

import PGF.CId
import PGF.Data
import PGF.ByteCode

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 -> Doc
ppPGF PGF
pgf = Language -> Abstr -> Doc
ppAbs (PGF -> Language
absname PGF
pgf) (PGF -> Abstr
abstract PGF
pgf) Doc -> Doc -> Doc
$$ (Language -> Concr -> Doc) -> Map Language Concr -> Doc
forall a b. (a -> b -> Doc) -> Map a b -> Doc
ppAll Language -> Concr -> Doc
ppCnc (PGF -> Map Language Concr
concretes PGF
pgf)

ppAbs :: Language -> Abstr -> Doc
ppAbs :: Language -> Abstr -> Doc
ppAbs Language
name Abstr
a = String -> Doc
text String
"abstract" Doc -> Doc -> Doc
<+> Language -> Doc
ppCId Language
name Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'{' Doc -> Doc -> Doc
$$
               Int -> Doc -> Doc
nest Int
2 ((Language -> Literal -> Doc) -> Map Language Literal -> Doc
forall a b. (a -> b -> Doc) -> Map a b -> Doc
ppAll Language -> Literal -> Doc
ppFlag (Abstr -> Map Language Literal
aflags Abstr
a) Doc -> Doc -> Doc
$$
                       (Language -> ([Hypo], [(Double, Language)], Double) -> Doc)
-> Map Language ([Hypo], [(Double, Language)], Double) -> Doc
forall a b. (a -> b -> Doc) -> Map a b -> Doc
ppAll Language -> ([Hypo], [(Double, Language)], Double) -> Doc
ppCat (Abstr -> Map Language ([Hypo], [(Double, Language)], Double)
cats Abstr
a) Doc -> Doc -> Doc
$$
                       (Language
 -> (Type, Int, Maybe ([Equation], [[Instr]]), Double) -> Doc)
-> Map Language (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> Doc
forall a b. (a -> b -> Doc) -> Map a b -> Doc
ppAll Language
-> (Type, Int, Maybe ([Equation], [[Instr]]), Double) -> Doc
ppFun (Abstr
-> Map Language (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs Abstr
a)) Doc -> Doc -> Doc
$$
               Char -> Doc
char Char
'}'

ppFlag :: CId -> Literal -> Doc
ppFlag :: Language -> Literal -> Doc
ppFlag Language
flag Literal
value = String -> Doc
text String
"flag" Doc -> Doc -> Doc
<+> Language -> Doc
ppCId Language
flag Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> Literal -> Doc
ppLit Literal
value Doc -> Doc -> Doc
<+> Char -> Doc
char Char
';'

ppCat :: CId -> ([Hypo],[(Double,CId)],Double) -> Doc
ppCat :: Language -> ([Hypo], [(Double, Language)], Double) -> Doc
ppCat Language
c ([Hypo]
hyps,[(Double, Language)]
_,Double
_) = String -> Doc
text String
"cat" Doc -> Doc -> Doc
<+> Language -> Doc
ppCId Language
c Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (([Language], [Doc]) -> [Doc]
forall a b. (a, b) -> b
snd (([Language] -> Hypo -> ([Language], Doc))
-> [Language] -> [Hypo] -> ([Language], [Doc])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (Int -> [Language] -> Hypo -> ([Language], Doc)
ppHypo Int
4) [] [Hypo]
hyps)) Doc -> Doc -> Doc
<+> Char -> Doc
char Char
';'

ppFun :: CId -> (Type,Int,Maybe ([Equation],[[Instr]]),Double) -> Doc
ppFun :: Language
-> (Type, Int, Maybe ([Equation], [[Instr]]), Double) -> Doc
ppFun Language
f (Type
t,Int
_,Just ([Equation]
eqs,[[Instr]]
code),Double
_) = String -> Doc
text String
"fun" Doc -> Doc -> Doc
<+> Language -> Doc
ppCId Language
f Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> Int -> [Language] -> Type -> Doc
ppType Int
0 [] Type
t Doc -> Doc -> Doc
<+> Char -> Doc
char Char
';' Doc -> Doc -> Doc
$$
                                  (if [Equation] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Equation]
eqs
                                     then Doc
empty
                                     else String -> Doc
text String
"def" Doc -> Doc -> Doc
<+> [Doc] -> Doc
vcat [let scope :: [Language]
scope = ([Language] -> Patt -> [Language])
-> [Language] -> [Patt] -> [Language]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Language] -> Patt -> [Language]
pattScope [] [Patt]
patts
                                                                   ds :: [Doc]
ds    = (Patt -> Doc) -> [Patt] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [Language] -> Patt -> Doc
ppPatt Int
9 [Language]
scope) [Patt]
patts
                                                               in Language -> Doc
ppCId Language
f Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep [Doc]
ds Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> Int -> [Language] -> Expr -> Doc
ppExpr Int
0 [Language]
scope Expr
res Doc -> Doc -> Doc
<+> Char -> Doc
char Char
';' | Equ [Patt]
patts Expr
res <- [Equation]
eqs]) Doc -> Doc -> Doc
$$
                                  Int -> [[Instr]] -> Doc
ppCode Int
0 [[Instr]]
code
ppFun Language
f (Type
t,Int
_,Maybe ([Equation], [[Instr]])
Nothing,Double
_)         = String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> Language -> Doc
ppCId Language
f Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> Int -> [Language] -> Type -> Doc
ppType Int
0 [] Type
t Doc -> Doc -> Doc
<+> Char -> Doc
char Char
';'

ppCnc :: Language -> Concr -> Doc
ppCnc :: Language -> Concr -> Doc
ppCnc Language
name Concr
cnc =
  String -> Doc
text String
"concrete" Doc -> Doc -> Doc
<+> Language -> Doc
ppCId Language
name Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'{' Doc -> Doc -> Doc
$$
  Int -> Doc -> Doc
nest Int
2 ((Language -> Literal -> Doc) -> Map Language Literal -> Doc
forall a b. (a -> b -> Doc) -> Map a b -> Doc
ppAll Language -> Literal -> Doc
ppFlag (Concr -> Map Language Literal
cflags Concr
cnc) Doc -> Doc -> Doc
$$
          String -> Doc
text String
"productions" Doc -> Doc -> Doc
$$
          Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat [(Int, Production) -> Doc
ppProduction (Int
fcat,Production
prod) | (Int
fcat,Set Production
set) <- IntMap (Set Production) -> [(Int, Set Production)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList (Concr -> IntMap (Set Production)
productions Concr
cnc), Production
prod <- Set Production -> [Production]
forall a. Set a -> [a]
Set.toList Set Production
set]) Doc -> Doc -> Doc
$$
          String -> Doc
text String
"lindefs" Doc -> Doc -> Doc
$$
          Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat (((Int, [Int]) -> [Doc]) -> [(Int, [Int])] -> [Doc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int, [Int]) -> [Doc]
ppLinDefs (IntMap [Int] -> [(Int, [Int])]
forall a. IntMap a -> [(Int, a)]
IntMap.toList (Concr -> IntMap [Int]
lindefs Concr
cnc)))) Doc -> Doc -> Doc
$$
          String -> Doc
text String
"linrefs" Doc -> Doc -> Doc
$$
          Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat (((Int, [Int]) -> [Doc]) -> [(Int, [Int])] -> [Doc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int, [Int]) -> [Doc]
ppLinRefs (IntMap [Int] -> [(Int, [Int])]
forall a. IntMap a -> [(Int, a)]
IntMap.toList (Concr -> IntMap [Int]
linrefs Concr
cnc)))) Doc -> Doc -> Doc
$$
          String -> Doc
text String
"lin" Doc -> Doc -> Doc
$$
          Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat (((Int, CncFun) -> Doc) -> [(Int, CncFun)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int, CncFun) -> Doc
ppCncFun (Array Int CncFun -> [(Int, CncFun)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs (Concr -> Array Int CncFun
cncfuns Concr
cnc)))) Doc -> Doc -> Doc
$$
          String -> Doc
text String
"sequences" Doc -> Doc -> Doc
$$
          Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat (((Int, Array Int Symbol) -> Doc)
-> [(Int, Array Int Symbol)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Array Int Symbol) -> Doc
forall (a :: * -> * -> *) i.
(IArray a Symbol, Ix i) =>
(Int, a i Symbol) -> Doc
ppSeq (Array Int (Array Int Symbol) -> [(Int, Array Int Symbol)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs (Concr -> Array Int (Array Int Symbol)
sequences Concr
cnc)))) Doc -> Doc -> Doc
$$
          String -> Doc
text String
"categories" Doc -> Doc -> Doc
$$
          Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat (((Language, CncCat) -> Doc) -> [(Language, CncCat)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Language, CncCat) -> Doc
ppCncCat (Map Language CncCat -> [(Language, CncCat)]
forall k a. Map k a -> [(k, a)]
Map.toList (Concr -> Map Language CncCat
cnccats Concr
cnc)))) Doc -> Doc -> Doc
$$
          String -> Doc
text String
"printnames" Doc -> Doc -> Doc
$$
          Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat (((Language, String) -> Doc) -> [(Language, String)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Language, String) -> Doc
ppPrintName (Map Language String -> [(Language, String)]
forall k a. Map k a -> [(k, a)]
Map.toList (Concr -> Map Language String
printnames Concr
cnc))))) Doc -> Doc -> Doc
$$
  Char -> Doc
char Char
'}'

ppCncArg :: PArg -> Doc
ppCncArg :: PArg -> Doc
ppCncArg (PArg [(Int, Int)]
hyps Int
fid)
  | [(Int, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Int)]
hyps = Int -> Doc
ppFId Int
fid
  | Bool
otherwise = [Doc] -> Doc
hsep (((Int, Int) -> Doc) -> [(Int, Int)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Doc
ppFId (Int -> Doc) -> ((Int, Int) -> Int) -> (Int, Int) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> b
snd) [(Int, Int)]
hyps) Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> Int -> Doc
ppFId Int
fid

ppProduction :: (Int, Production) -> Doc
ppProduction (Int
fid,PApply Int
funid [PArg]
args) =
  Int -> Doc
ppFId Int
fid Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> Int -> Doc
ppFunId Int
funid Doc -> Doc -> Doc
<> Doc -> Doc
brackets ([Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ((PArg -> Doc) -> [PArg] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map PArg -> Doc
ppCncArg [PArg]
args)))
ppProduction (Int
fid,PCoerce Int
arg) =
  Int -> Doc
ppFId Int
fid Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'_' Doc -> Doc -> Doc
<> Doc -> Doc
brackets (Int -> Doc
ppFId Int
arg)
ppProduction (Int
fid,PConst Language
_ Expr
_ [String]
ss) =
  Int -> Doc
ppFId Int
fid Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> [String] -> Doc
ppStrs [String]
ss

ppCncFun :: (Int, CncFun) -> Doc
ppCncFun (Int
funid,CncFun Language
fun UArray Int Int
arr) =
  Int -> Doc
ppFunId Int
funid Doc -> Doc -> Doc
<+> String -> Doc
text String
":=" Doc -> Doc -> Doc
<+> Doc -> Doc
parens ([Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ((Int -> Doc) -> [Int] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Doc
ppSeqId (UArray Int Int -> [Int]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems UArray Int Int
arr)))) Doc -> Doc -> Doc
<+> Doc -> Doc
brackets (Language -> Doc
ppCId Language
fun)

ppLinDefs :: (Int, [Int]) -> [Doc]
ppLinDefs (Int
fid,[Int]
funids) = 
  [Int -> Doc
ppFId Int
fid Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> Int -> Doc
ppFunId Int
funid Doc -> Doc -> Doc
<> Doc -> Doc
brackets (Int -> Doc
ppFId Int
fidVar) | Int
funid <- [Int]
funids]

ppLinRefs :: (Int, [Int]) -> [Doc]
ppLinRefs (Int
fid,[Int]
funids) = 
  [Int -> Doc
ppFId Int
fidVar Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> Int -> Doc
ppFunId Int
funid Doc -> Doc -> Doc
<> Doc -> Doc
brackets (Int -> Doc
ppFId Int
fid) | Int
funid <- [Int]
funids]

ppSeq :: (Int, a i Symbol) -> Doc
ppSeq (Int
seqid,a i Symbol
seq) = 
  Int -> Doc
ppSeqId Int
seqid Doc -> Doc -> Doc
<+> String -> Doc
text String
":=" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((Symbol -> Doc) -> [Symbol] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Symbol -> Doc
ppSymbol (a i Symbol -> [Symbol]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems a i Symbol
seq))

ppCncCat :: (Language, CncCat) -> Doc
ppCncCat (Language
id,(CncCat Int
start Int
end Array Int String
labels)) =
  Language -> Doc
ppCId Language
id Doc -> Doc -> Doc
<+> String -> Doc
text String
":=" Doc -> Doc -> Doc
<+> (String -> Doc
text String
"range " Doc -> Doc -> Doc
<+> Doc -> Doc
brackets (Int -> Doc
ppFId Int
start Doc -> Doc -> Doc
<+> String -> Doc
text String
".." Doc -> Doc -> Doc
<+> Int -> Doc
ppFId Int
end) Doc -> Doc -> Doc
$$
                              String -> Doc
text String
"labels" Doc -> Doc -> Doc
<+> Doc -> Doc
brackets ([Doc] -> Doc
vcat ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
text (String -> Doc) -> (String -> String) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show) (Array Int String -> [String]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems Array Int String
labels))))

ppPrintName :: (Language, String) -> Doc
ppPrintName (Language
id,String
name) =
  Language -> Doc
ppCId Language
id Doc -> Doc -> Doc
<+> String -> Doc
text String
":=" Doc -> Doc -> Doc
<+> [String] -> Doc
ppStrs [String
name]

ppSymbol :: Symbol -> Doc
ppSymbol (SymCat Int
d Int
r) = Char -> Doc
char Char
'<' Doc -> Doc -> Doc
<> Int -> Doc
int Int
d Doc -> Doc -> Doc
<> Doc
comma Doc -> Doc -> Doc
<> Int -> Doc
int Int
r Doc -> Doc -> Doc
<> Char -> Doc
char Char
'>'
ppSymbol (SymLit Int
d Int
r) = Char -> Doc
char Char
'{' Doc -> Doc -> Doc
<> Int -> Doc
int Int
d Doc -> Doc -> Doc
<> Doc
comma Doc -> Doc -> Doc
<> Int -> Doc
int Int
r Doc -> Doc -> Doc
<> Char -> Doc
char Char
'}'
ppSymbol (SymVar Int
d Int
r) = Char -> Doc
char Char
'<' Doc -> Doc -> Doc
<> Int -> Doc
int Int
d Doc -> Doc -> Doc
<> Doc
comma Doc -> Doc -> Doc
<> Char -> Doc
char Char
'$' Doc -> Doc -> Doc
<> Int -> Doc
int Int
r Doc -> Doc -> Doc
<> Char -> Doc
char Char
'>'
ppSymbol (SymKS String
t)    = Doc -> Doc
doubleQuotes (String -> Doc
text String
t)
ppSymbol Symbol
SymNE        = String -> Doc
text String
"nonExist"
ppSymbol Symbol
SymBIND      = String -> Doc
text String
"BIND"
ppSymbol Symbol
SymSOFT_BIND = String -> Doc
text String
"SOFT_BIND"
ppSymbol Symbol
SymSOFT_SPACE= String -> Doc
text String
"SOFT_SPACE"
ppSymbol Symbol
SymCAPIT     = String -> Doc
text String
"CAPIT"
ppSymbol Symbol
SymALL_CAPIT = String -> Doc
text String
"ALL_CAPIT"
ppSymbol (SymKP [Symbol]
syms [([Symbol], [String])]
alts) = String -> Doc
text String
"pre" Doc -> Doc -> Doc
<+> Doc -> Doc
braces ([Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
semi ([Doc] -> Doc
hsep ((Symbol -> Doc) -> [Symbol] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Symbol -> Doc
ppSymbol [Symbol]
syms) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (([Symbol], [String]) -> Doc) -> [([Symbol], [String])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([Symbol], [String]) -> Doc
ppAlt [([Symbol], [String])]
alts)))

ppAlt :: ([Symbol], [String]) -> Doc
ppAlt ([Symbol]
syms,[String]
ps) = [Doc] -> Doc
hsep ((Symbol -> Doc) -> [Symbol] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Symbol -> Doc
ppSymbol [Symbol]
syms) Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'/' Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
doubleQuotes (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text) [String]
ps)

ppStrs :: [String] -> Doc
ppStrs [String]
ss = Doc -> Doc
doubleQuotes ([Doc] -> Doc
hsep ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text [String]
ss))

ppFId :: Int -> Doc
ppFId Int
fid
  | Int
fid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
fidString = String -> Doc
text String
"CString"
  | Int
fid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
fidInt    = String -> Doc
text String
"CInt"
  | Int
fid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
fidFloat  = String -> Doc
text String
"CFloat"
  | Int
fid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
fidVar    = String -> Doc
text String
"CVar"
  | Int
fid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
fidStart  = String -> Doc
text String
"CStart"
  | Bool
otherwise        = Char -> Doc
char Char
'C' Doc -> Doc -> Doc
<> Int -> Doc
int Int
fid

ppFunId :: Int -> Doc
ppFunId Int
funid = Char -> Doc
char Char
'F' Doc -> Doc -> Doc
<> Int -> Doc
int Int
funid
ppSeqId :: Int -> Doc
ppSeqId Int
seqid = Char -> Doc
char Char
'S' Doc -> Doc -> Doc
<> Int -> Doc
int Int
seqid

-- Utilities

ppAll :: (a -> b -> Doc) -> Map.Map a b -> Doc
ppAll :: (a -> b -> Doc) -> Map a b -> Doc
ppAll a -> b -> Doc
p Map a b
m = [Doc] -> Doc
vcat [ a -> b -> Doc
p a
k b
v | (a
k,b
v) <- Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
Map.toList Map a b
m]