forked from GitHub/gf-core
Introducing GF.Text.Pretty for more concise pretty printers and GF.Infra.Location for modularity
GF.Text.Pretty provides the class Pretty and overloaded versions of the pretty printing combinators in Text.PrettyPrint, allowing pretty printable values to be used directly instead of first having to convert them to Doc with functions like text, int, char and ppIdent. Some modules have been converted to use GF.Text.Pretty, but not all. Precedences could be added to simplify the pretty printers for terms and patterns. GF.Infra.Location contains the types Location and L, factored out from GF.Grammar.Grammar, and the class HasSourcePath. This allowed the import of GF.Grammar.Grammar to be removed from GF.Infra.CheckM, making it more like a pure library module.
This commit is contained in:
hallgren
@@ -36,7 +36,7 @@ module GF.Grammar.Grammar (
|
||||
PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence,
|
||||
|
||||
Info(..),
|
||||
Location(..), L(..), unLoc, noLoc,
|
||||
Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
|
||||
Type,
|
||||
Cat,
|
||||
Fun,
|
||||
@@ -63,6 +63,7 @@ module GF.Grammar.Grammar (
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option ---
|
||||
import GF.Infra.Location
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
@@ -74,7 +75,7 @@ import Data.Array.Unboxed
|
||||
import qualified Data.Map as Map
|
||||
--import qualified Data.Set as Set
|
||||
--import qualified Data.IntMap as IntMap
|
||||
import Text.PrettyPrint
|
||||
import GF.Text.Pretty
|
||||
--import System.FilePath
|
||||
--import Control.Monad.Identity
|
||||
|
||||
@@ -98,6 +99,8 @@ data SourceModInfo = ModInfo {
|
||||
jments :: Map.Map Ident Info
|
||||
}
|
||||
|
||||
instance HasSourcePath SourceModInfo where sourcePath = msrc
|
||||
|
||||
type SourceModule = (Ident, SourceModInfo)
|
||||
|
||||
-- | encoding the type of the module
|
||||
@@ -200,12 +203,12 @@ abstractOfConcrete gr c = do
|
||||
n <- lookupModule gr c
|
||||
case mtype n of
|
||||
MTConcrete a -> return a
|
||||
_ -> raise $ render (text "expected concrete" <+> ppIdent c)
|
||||
_ -> raise $ render ("expected concrete" <+> c)
|
||||
|
||||
lookupModule :: ErrorMonad m => SourceGrammar -> Ident -> m SourceModInfo
|
||||
lookupModule gr m = case Map.lookup m (moduleMap gr) of
|
||||
Just i -> return i
|
||||
Nothing -> raise $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr)))
|
||||
Nothing -> raise $ render ("unknown module" <+> m <+> "among" <+> hsep (map fst (modules gr)))
|
||||
|
||||
isModAbs :: SourceModInfo -> Bool
|
||||
isModAbs m =
|
||||
@@ -263,7 +266,7 @@ allAbstracts :: SourceGrammar -> [Ident]
|
||||
allAbstracts gr =
|
||||
case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of
|
||||
Left is -> is
|
||||
Right cycles -> error $ render (text "Cyclic abstract modules:" <+> vcat (map (hsep . map ppIdent) cycles))
|
||||
Right cycles -> error $ render ("Cyclic abstract modules:" <+> vcat (map hsep cycles))
|
||||
|
||||
-- | the last abstract in dependency order (head of list)
|
||||
greatestAbstract :: SourceGrammar -> Maybe Ident
|
||||
@@ -332,23 +335,6 @@ data Info =
|
||||
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
|
||||
deriving Show
|
||||
|
||||
data Location
|
||||
= NoLoc
|
||||
| Local Int Int
|
||||
| External FilePath Location
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
data L a = L Location a -- location information
|
||||
deriving Show
|
||||
|
||||
instance Functor L where
|
||||
fmap f (L loc x) = L loc (f x)
|
||||
|
||||
unLoc :: L a -> a
|
||||
unLoc (L _ x) = x
|
||||
|
||||
noLoc = L NoLoc
|
||||
|
||||
type Type = Term
|
||||
type Cat = QIdent
|
||||
type Fun = QIdent
|
||||
|
||||
@@ -42,7 +42,7 @@ import GF.Grammar.Lockfield
|
||||
import Data.List (sortBy)
|
||||
--import Data.Maybe (maybe)
|
||||
--import Control.Monad
|
||||
import Text.PrettyPrint
|
||||
import GF.Text.Pretty
|
||||
import qualified Data.Map as Map
|
||||
|
||||
-- whether lock fields are added in reuse
|
||||
@@ -83,7 +83,7 @@ lookupResDefLoc gr (m,c)
|
||||
AnyInd _ n -> look n c
|
||||
ResParam _ _ -> return (noLoc (QC (m,c)))
|
||||
ResValue _ -> return (noLoc (QC (m,c)))
|
||||
_ -> raise $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m)
|
||||
_ -> raise $ render (c <+> "is not defined in resource" <+> m)
|
||||
|
||||
lookupResType :: ErrorMonad m => SourceGrammar -> QIdent -> m Type
|
||||
lookupResType gr (m,c) = do
|
||||
@@ -99,7 +99,7 @@ lookupResType gr (m,c) = do
|
||||
AnyInd _ n -> lookupResType gr (n,c)
|
||||
ResParam _ _ -> return typePType
|
||||
ResValue (L _ t) -> return t
|
||||
_ -> raise $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
|
||||
_ -> raise $ render (c <+> "has no type defined in resource" <+> m)
|
||||
|
||||
lookupOverload :: ErrorMonad m => SourceGrammar -> QIdent -> m [([Type],(Type,Term))]
|
||||
lookupOverload gr (m,c) = do
|
||||
@@ -112,7 +112,7 @@ lookupOverload gr (m,c) = do
|
||||
concat tss
|
||||
|
||||
AnyInd _ n -> lookupOverload gr (n,c)
|
||||
_ -> raise $ render (ppIdent c <+> text "is not an overloaded operation")
|
||||
_ -> raise $ render (c <+> "is not an overloaded operation")
|
||||
|
||||
-- | returns the original 'Info' and the module where it was found
|
||||
lookupOrigInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m (Ident,Info)
|
||||
@@ -132,7 +132,7 @@ lookupParamValues gr c = do
|
||||
(_,info) <- lookupOrigInfo gr c
|
||||
case info of
|
||||
ResParam _ (Just pvs) -> return pvs
|
||||
_ -> raise $ render (ppQIdent Qualified c <+> text "has no parameter values defined")
|
||||
_ -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
|
||||
|
||||
allParamValues :: ErrorMonad m => SourceGrammar -> Type -> m [Term]
|
||||
allParamValues cnc ptyp =
|
||||
@@ -148,13 +148,13 @@ allParamValues cnc ptyp =
|
||||
pvs <- allParamValues cnc pt
|
||||
vvs <- allParamValues cnc vt
|
||||
return [V pt ts | ts <- combinations (replicate (length pvs) vvs)]
|
||||
_ -> raise (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp))
|
||||
_ -> raise (render ("cannot find parameter values for" <+> ptyp))
|
||||
where
|
||||
-- to normalize records and record types
|
||||
sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
|
||||
|
||||
lookupAbsDef :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m (Maybe Int,Maybe [Equation])
|
||||
lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do
|
||||
lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
|
||||
info <- lookupQIdentInfo gr (m,c)
|
||||
case info of
|
||||
AbsFun _ a d _ -> return (a,fmap (map unLoc) d)
|
||||
@@ -168,7 +168,7 @@ lookupLincat gr m c = do
|
||||
case info of
|
||||
CncCat (Just (L _ t)) _ _ _ _ -> return t
|
||||
AnyInd _ n -> lookupLincat gr n c
|
||||
_ -> raise (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
|
||||
_ -> raise (render (c <+> "has no linearization type in" <+> m))
|
||||
|
||||
-- | this is needed at compile time
|
||||
lookupFunType :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type
|
||||
@@ -177,7 +177,7 @@ lookupFunType gr m c = do
|
||||
case info of
|
||||
AbsFun (Just (L _ t)) _ _ _ -> return t
|
||||
AnyInd _ n -> lookupFunType gr n c
|
||||
_ -> raise (render (text "cannot find type of" <+> ppIdent c))
|
||||
_ -> raise (render ("cannot find type of" <+> c))
|
||||
|
||||
-- | this is needed at compile time
|
||||
lookupCatContext :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Context
|
||||
@@ -186,7 +186,7 @@ lookupCatContext gr m c = do
|
||||
case info of
|
||||
AbsCat (Just (L _ co)) -> return co
|
||||
AnyInd _ n -> lookupCatContext gr n c
|
||||
_ -> raise (render (text "unknown category" <+> ppIdent c))
|
||||
_ -> raise (render ("unknown category" <+> c))
|
||||
|
||||
|
||||
-- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations
|
||||
|
||||
@@ -31,7 +31,7 @@ import qualified Data.Traversable as T(mapM)
|
||||
import Control.Monad (liftM, liftM2, liftM3)
|
||||
--import Data.Char (isDigit)
|
||||
import Data.List (sortBy,nub)
|
||||
import Text.PrettyPrint
|
||||
import GF.Text.Pretty
|
||||
|
||||
typeForm :: Type -> (Context, Cat, [Term])
|
||||
typeForm t =
|
||||
@@ -45,7 +45,7 @@ typeForm t =
|
||||
Q c -> ([],c,[])
|
||||
QC c -> ([],c,[])
|
||||
Sort c -> ([],(identW, c),[])
|
||||
_ -> error (render (text "no normal form of type" <+> ppTerm Unqualified 0 t))
|
||||
_ -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
|
||||
|
||||
typeFormCnc :: Type -> (Context, Type)
|
||||
typeFormCnc t =
|
||||
@@ -170,7 +170,7 @@ projectRec :: Label -> [Assign] -> Term
|
||||
projectRec l rs =
|
||||
case lookup l rs of
|
||||
Just (_,t) -> t
|
||||
Nothing -> error (render (text "no value for label" <+> ppLabel l))
|
||||
Nothing -> error (render ("no value for label" <+> l))
|
||||
|
||||
zipAssign :: [Label] -> [Term] -> [Assign]
|
||||
zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
|
||||
@@ -194,7 +194,7 @@ mkRecType = mkRecTypeN 0
|
||||
record2subst :: Term -> Err Substitution
|
||||
record2subst t = case t of
|
||||
R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs]
|
||||
_ -> Bad (render (text "record expected, found" <+> ppTerm Unqualified 0 t))
|
||||
_ -> Bad (render ("record expected, found" <+> ppTerm Unqualified 0 t))
|
||||
|
||||
typeType, typePType, typeStr, typeTok, typeStrs :: Term
|
||||
|
||||
@@ -273,8 +273,8 @@ plusRecType t1 t2 = case (t1, t2) of
|
||||
(RecType r1, RecType r2) -> case
|
||||
filter (`elem` (map fst r1)) (map fst r2) of
|
||||
[] -> return (RecType (r1 ++ r2))
|
||||
ls -> raise $ render (text "clashing labels" <+> hsep (map ppLabel ls))
|
||||
_ -> raise $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
|
||||
ls -> raise $ render ("clashing labels" <+> hsep ls)
|
||||
_ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
|
||||
|
||||
--plusRecord :: Term -> Term -> Err Term
|
||||
plusRecord t1 t2 =
|
||||
@@ -283,7 +283,7 @@ plusRecord t1 t2 =
|
||||
(l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
|
||||
(_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV
|
||||
(FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV
|
||||
_ -> raise $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
|
||||
_ -> raise $ render ("cannot add records" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
|
||||
|
||||
-- | default linearization type
|
||||
defLinType :: Type
|
||||
@@ -386,7 +386,7 @@ term2patt trm = case termForm trm of
|
||||
Ok ([], Cn c, []) -> do
|
||||
return (PMacro c)
|
||||
|
||||
_ -> Bad $ render (text "no pattern corresponds to term" <+> ppTerm Unqualified 0 trm)
|
||||
_ -> Bad $ render ("no pattern corresponds to term" <+> ppTerm Unqualified 0 trm)
|
||||
|
||||
patt2term :: Patt -> Term
|
||||
patt2term pt = case pt of
|
||||
@@ -450,7 +450,7 @@ strsFromTerm t = case t of
|
||||
]
|
||||
FV ts -> mapM strsFromTerm ts >>= return . concat
|
||||
Strs ts -> mapM strsFromTerm ts >>= return . concat
|
||||
_ -> raise (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
|
||||
_ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t))
|
||||
|
||||
-- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
|
||||
stringFromTerm :: Term -> String
|
||||
@@ -609,7 +609,7 @@ topoSortJments :: ErrorMonad m => SourceModule -> m [(Ident,Info)]
|
||||
topoSortJments (m,mi) = do
|
||||
is <- either
|
||||
return
|
||||
(\cyc -> raise (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc)))))
|
||||
(\cyc -> raise (render ("circular definitions:" <+> fsep (head cyc))))
|
||||
(topoTest (allDependencies (==m) (jments mi)))
|
||||
return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]])
|
||||
|
||||
@@ -617,8 +617,8 @@ topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]]
|
||||
topoSortJments2 (m,mi) = do
|
||||
iss <- either
|
||||
return
|
||||
(\cyc -> raise (render (text "circular definitions:"
|
||||
<+> fsep (map ppIdent (head cyc)))))
|
||||
(\cyc -> raise (render ("circular definitions:"
|
||||
<+> fsep (head cyc))))
|
||||
(topoTest2 (allDependencies (==m) (jments mi)))
|
||||
return
|
||||
[[(i,info) | i<-is,Ok info<-[lookupTree showIdent i (jments mi)]] | is<-iss]
|
||||
|
||||
@@ -22,20 +22,20 @@ import GF.Data.Operations
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.Printer
|
||||
--import GF.Grammar.Printer
|
||||
|
||||
--import Data.List
|
||||
import Control.Monad
|
||||
import Text.PrettyPrint
|
||||
import GF.Text.Pretty
|
||||
--import Debug.Trace
|
||||
|
||||
matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
|
||||
matchPattern pts term =
|
||||
if not (isInConstantForm term)
|
||||
then raise (render (text "variables occur in" <+> ppTerm Unqualified 0 term))
|
||||
then raise (render ("variables occur in" <+> pp term))
|
||||
else do
|
||||
term' <- mkK term
|
||||
errIn (render (text "trying patterns" <+> hsep (punctuate comma (map (ppPatt Unqualified 0 . fst) pts)))) $
|
||||
errIn (render ("trying patterns" <+> hsep (punctuate ',' (map fst pts)))) $
|
||||
findMatch [([p],t) | (p,t) <- pts] [term']
|
||||
where
|
||||
-- to capture all Str with string pattern matching
|
||||
@@ -49,7 +49,7 @@ matchPattern pts term =
|
||||
K w -> return [w]
|
||||
C v w -> liftM2 (++) (getS v) (getS w)
|
||||
Empty -> return []
|
||||
_ -> raise (render (text "cannot get string from" <+> ppTerm Unqualified 0 s))
|
||||
_ -> raise (render ("cannot get string from" <+> s))
|
||||
|
||||
testOvershadow :: ErrorMonad m => [Patt] -> [Term] -> m [Patt]
|
||||
testOvershadow pts vs = do
|
||||
@@ -60,10 +60,10 @@ testOvershadow pts vs = do
|
||||
|
||||
findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
|
||||
findMatch cases terms = case cases of
|
||||
[] -> raise (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms))))
|
||||
[] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms)))
|
||||
(patts,_):_ | length patts /= length terms ->
|
||||
raise (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+>
|
||||
text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms)))
|
||||
raise (render ("wrong number of args for patterns :" <+> hsep patts <+>
|
||||
"cannot take" <+> hsep terms))
|
||||
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
|
||||
Ok substs -> return (val, concat substs)
|
||||
_ -> findMatch cc terms
|
||||
@@ -116,7 +116,7 @@ tryMatch (p,t) = do
|
||||
|
||||
(PNeg p',_) -> case tryMatch (p',t) of
|
||||
Bad _ -> return []
|
||||
_ -> raise (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p))
|
||||
_ -> raise (render ("no match with negative pattern" <+> p))
|
||||
|
||||
(PSeq p1 p2, ([],K s, [])) -> matchPSeq p1 p2 s
|
||||
(PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s
|
||||
@@ -130,7 +130,7 @@ tryMatch (p,t) = do
|
||||
(PChar, ([],K [_], [])) -> return []
|
||||
(PChars cs, ([],K [c], [])) | elem c cs -> return []
|
||||
|
||||
_ -> raise (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t))
|
||||
_ -> raise (render ("no match in case expr for" <+> t))
|
||||
|
||||
matchPMSeq (m1,p1) (m2,p2) s = matchPSeq' m1 p1 m2 p2 s
|
||||
--matchPSeq p1 p2 s = matchPSeq' (0,maxBound::Int) p1 (0,maxBound::Int) p2 s
|
||||
|
||||
@@ -9,8 +9,6 @@
|
||||
|
||||
module GF.Grammar.Printer
|
||||
( TermPrintQual(..)
|
||||
, ppLabel
|
||||
, ppGrammar
|
||||
, ppModule
|
||||
, ppJudgement
|
||||
, ppParams
|
||||
@@ -18,7 +16,6 @@ module GF.Grammar.Printer
|
||||
, ppPatt
|
||||
, ppValue
|
||||
, ppConstrs
|
||||
, ppLocation
|
||||
, ppQIdent
|
||||
, ppMeta
|
||||
, getAbs
|
||||
@@ -31,7 +28,7 @@ import GF.Grammar.Grammar
|
||||
|
||||
import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
|
||||
|
||||
import Text.PrettyPrint
|
||||
import GF.Text.Pretty
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.List (intersperse)
|
||||
import qualified Data.Map as Map
|
||||
@@ -43,8 +40,8 @@ data TermPrintQual
|
||||
= Unqualified | Qualified | Internal
|
||||
deriving Eq
|
||||
|
||||
ppGrammar :: SourceGrammar -> Doc
|
||||
ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr
|
||||
instance Pretty SourceGrammar where
|
||||
pp = vcat . map (ppModule Qualified) . modules
|
||||
|
||||
ppModule :: TermPrintQual -> SourceModule -> Doc
|
||||
ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
|
||||
@@ -54,288 +51,286 @@ ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
|
||||
maybe empty (ppSequences q) mseqs) $$
|
||||
ftr
|
||||
where
|
||||
hdr = complModDoc <+> modTypeDoc <+> equals <+>
|
||||
hsep (intersperse (text "**") $
|
||||
hdr = complModDoc <+> modTypeDoc <+> '=' <+>
|
||||
hsep (intersperse (pp "**") $
|
||||
filter (not . isEmpty) $ [ commaPunct ppExtends exts
|
||||
, maybe empty ppWith with
|
||||
, if null opens
|
||||
then lbrace
|
||||
else text "open" <+> commaPunct ppOpenSpec opens <+> text "in" <+> lbrace
|
||||
then pp '{'
|
||||
else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{'
|
||||
])
|
||||
|
||||
ftr = rbrace
|
||||
ftr = '}'
|
||||
|
||||
complModDoc =
|
||||
case mstat of
|
||||
MSComplete -> empty
|
||||
MSIncomplete -> text "incomplete"
|
||||
MSIncomplete -> pp "incomplete"
|
||||
|
||||
modTypeDoc =
|
||||
case mtype of
|
||||
MTAbstract -> text "abstract" <+> ppIdent mn
|
||||
MTResource -> text "resource" <+> ppIdent mn
|
||||
MTConcrete abs -> text "concrete" <+> ppIdent mn <+> text "of" <+> ppIdent abs
|
||||
MTInterface -> text "interface" <+> ppIdent mn
|
||||
MTInstance ie -> text "instance" <+> ppIdent mn <+> text "of" <+> ppExtends ie
|
||||
MTAbstract -> "abstract" <+> mn
|
||||
MTResource -> "resource" <+> mn
|
||||
MTConcrete abs -> "concrete" <+> mn <+> "of" <+> abs
|
||||
MTInterface -> "interface" <+> mn
|
||||
MTInstance ie -> "instance" <+> mn <+> "of" <+> ppExtends ie
|
||||
|
||||
ppExtends (id,MIAll ) = ppIdent id
|
||||
ppExtends (id,MIOnly incs) = ppIdent id <+> brackets (commaPunct ppIdent incs)
|
||||
ppExtends (id,MIExcept incs) = ppIdent id <+> char '-' <+> brackets (commaPunct ppIdent incs)
|
||||
ppExtends (id,MIAll ) = pp id
|
||||
ppExtends (id,MIOnly incs) = id <+> brackets (commaPunct pp incs)
|
||||
ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs)
|
||||
|
||||
ppWith (id,ext,opens) = ppExtends (id,ext) <+> text "with" <+> commaPunct ppInstSpec opens
|
||||
ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens
|
||||
|
||||
ppOptions opts =
|
||||
text "flags" $$
|
||||
nest 2 (vcat [text option <+> equals <+> ppLit value <+> semi | (option,value) <- optionsGFO opts])
|
||||
"flags" $$
|
||||
nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
|
||||
|
||||
ppJudgement q (id, AbsCat pcont ) =
|
||||
text "cat" <+> ppIdent id <+>
|
||||
"cat" <+> id <+>
|
||||
(case pcont of
|
||||
Just (L _ cont) -> hsep (map (ppDecl q) cont)
|
||||
Nothing -> empty) <+> semi
|
||||
Nothing -> empty) <+> ';'
|
||||
ppJudgement q (id, AbsFun ptype _ pexp poper) =
|
||||
let kind | isNothing pexp = "data"
|
||||
| poper == Just False = "oper"
|
||||
| otherwise = "fun"
|
||||
in
|
||||
(case ptype of
|
||||
Just (L _ typ) -> text kind <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi
|
||||
Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case pexp of
|
||||
Just [] -> empty
|
||||
Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | L _ (ps,e) <- eqs]
|
||||
Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
|
||||
Nothing -> empty)
|
||||
ppJudgement q (id, ResParam pparams _) =
|
||||
text "param" <+> ppIdent id <+>
|
||||
"param" <+> id <+>
|
||||
(case pparams of
|
||||
Just (L _ ps) -> equals <+> ppParams q ps
|
||||
_ -> empty) <+> semi
|
||||
Just (L _ ps) -> '=' <+> ppParams q ps
|
||||
_ -> empty) <+> ';'
|
||||
ppJudgement q (id, ResValue pvalue) =
|
||||
text "-- param constructor" <+> ppIdent id <+> colon <+>
|
||||
"-- param constructor" <+> id <+> ':' <+>
|
||||
(case pvalue of
|
||||
(L _ ty) -> ppTerm q 0 ty) <+> semi
|
||||
(L _ ty) -> ppTerm q 0 ty) <+> ';'
|
||||
ppJudgement q (id, ResOper ptype pexp) =
|
||||
text "oper" <+> ppIdent id <+>
|
||||
(case ptype of {Just (L _ t) -> colon <+> ppTerm q 0 t; Nothing -> empty} $$
|
||||
case pexp of {Just (L _ e) -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi
|
||||
"oper" <+> id <+>
|
||||
(case ptype of {Just (L _ t) -> ':' <+> ppTerm q 0 t; Nothing -> empty} $$
|
||||
case pexp of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';'
|
||||
ppJudgement q (id, ResOverload ids defs) =
|
||||
text "oper" <+> ppIdent id <+> equals <+>
|
||||
(text "overload" <+> lbrace $$
|
||||
nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e <+> semi) | (L _ ty,L _ e) <- defs]) $$
|
||||
rbrace) <+> semi
|
||||
"oper" <+> id <+> '=' <+>
|
||||
("overload" <+> '{' $$
|
||||
nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$
|
||||
'}') <+> ';'
|
||||
ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
|
||||
(case pcat of
|
||||
Just (L _ typ) -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi
|
||||
Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case pdef of
|
||||
Just (L _ exp) -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
|
||||
Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case pref of
|
||||
Just (L _ exp) -> text "linref" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
|
||||
Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case pprn of
|
||||
Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
|
||||
Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case (mpmcfg,q) of
|
||||
(Just (PMCFG prods funs),Internal)
|
||||
-> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$
|
||||
-> "pmcfg" <+> id <+> '=' <+> '{' $$
|
||||
nest 2 (vcat (map ppProduction prods) $$
|
||||
space $$
|
||||
vcat (map (\(funid,arr) -> ppFunId funid <+> text ":=" <+>
|
||||
parens (hcat (punctuate comma (map ppSeqId (Array.elems arr)))))
|
||||
' ' $$
|
||||
vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
|
||||
parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
|
||||
(Array.assocs funs))) $$
|
||||
char '}'
|
||||
'}'
|
||||
_ -> empty)
|
||||
ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) =
|
||||
(case pdef of
|
||||
Just (L _ e) -> let (xs,e') = getAbs e
|
||||
in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi
|
||||
in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case pprn of
|
||||
Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
|
||||
Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case (mpmcfg,q) of
|
||||
(Just (PMCFG prods funs),Internal)
|
||||
-> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$
|
||||
-> "pmcfg" <+> id <+> '=' <+> '{' $$
|
||||
nest 2 (vcat (map ppProduction prods) $$
|
||||
space $$
|
||||
vcat (map (\(funid,arr) -> ppFunId funid <+> text ":=" <+>
|
||||
parens (hcat (punctuate comma (map ppSeqId (Array.elems arr)))))
|
||||
' ' $$
|
||||
vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
|
||||
parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
|
||||
(Array.assocs funs))) $$
|
||||
char '}'
|
||||
'}'
|
||||
_ -> empty)
|
||||
ppJudgement q (id, AnyInd cann mid) =
|
||||
case q of
|
||||
Internal -> text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi
|
||||
Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
|
||||
_ -> empty
|
||||
|
||||
instance Pretty Term where pp = ppTerm Unqualified 0
|
||||
|
||||
ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e)
|
||||
in prec d 0 (char '\\' <> commaPunct ppBind xs <+> text "->" <+> ppTerm q 0 e')
|
||||
in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e')
|
||||
ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of
|
||||
([],_) -> text "table" <+> lbrace $$
|
||||
nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
|
||||
rbrace
|
||||
(vs,e) -> prec d 0 (text "\\\\" <> commaPunct ppIdent vs <+> text "=>" <+> ppTerm q 0 e)
|
||||
ppTerm q d (T (TTyped t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$
|
||||
nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
|
||||
rbrace
|
||||
ppTerm q d (T (TComp t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$
|
||||
nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
|
||||
rbrace
|
||||
ppTerm q d (T (TWild t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$
|
||||
nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
|
||||
rbrace
|
||||
([],_) -> "table" <+> '{' $$
|
||||
nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
|
||||
'}'
|
||||
(vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e)
|
||||
ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
|
||||
nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
|
||||
'}'
|
||||
ppTerm q d (T (TComp t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
|
||||
nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
|
||||
'}'
|
||||
ppTerm q d (T (TWild t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
|
||||
nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
|
||||
'}'
|
||||
ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit
|
||||
then prec d 0 (ppTerm q 4 a <+> text "->" <+> ppTerm q 0 b)
|
||||
else prec d 0 (parens (ppBind (bt,x) <+> colon <+> ppTerm q 0 a) <+> text "->" <+> ppTerm q 0 b)
|
||||
ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> text "=>" <+> ppTerm q 0 vt)
|
||||
then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b)
|
||||
else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b)
|
||||
ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> ppTerm q 0 vt)
|
||||
ppTerm q d (Let l e) = let (ls,e') = getLet e
|
||||
in prec d 0 (text "let" <+> vcat (map (ppLocDef q) (l:ls)) $$ text "in" <+> ppTerm q 0 e')
|
||||
ppTerm q d (Example e s)=prec d 0 (text "in" <+> ppTerm q 5 e <+> str s)
|
||||
ppTerm q d (C e1 e2) =prec d 1 (hang (ppTerm q 2 e1) 2 (text "++" <+> ppTerm q 1 e2))
|
||||
ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> char '+' <+> ppTerm q 2 e2)
|
||||
in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e')
|
||||
ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s)
|
||||
ppTerm q d (C e1 e2) =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2))
|
||||
ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+' <+> ppTerm q 2 e2)
|
||||
ppTerm q d (S x y) = case x of
|
||||
T annot xs -> let e = case annot of
|
||||
TRaw -> y
|
||||
TTyped t -> Typed y t
|
||||
TComp t -> Typed y t
|
||||
TWild t -> Typed y t
|
||||
in text "case" <+> ppTerm q 0 e <+> text "of" <+> lbrace $$
|
||||
nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
|
||||
rbrace
|
||||
_ -> prec d 3 (hang (ppTerm q 3 x) 2 (text "!" <+> ppTerm q 4 y))
|
||||
ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> text "**" <+> ppTerm q 4 y)
|
||||
in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$
|
||||
nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
|
||||
'}'
|
||||
_ -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))
|
||||
ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
|
||||
ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
|
||||
ppTerm q d (V e es) = hang (text "table") 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate semi (map (ppTerm q 0) es)))])
|
||||
ppTerm q d (FV es) = text "variants" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))
|
||||
ppTerm q d (AdHocOverload es) = text "overload" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))
|
||||
ppTerm q d (Alts e xs) = prec d 4 (text "pre" <+> braces (ppTerm q 0 e <> semi <+> fsep (punctuate semi (map (ppAltern q) xs))))
|
||||
ppTerm q d (Strs es) = text "strs" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))
|
||||
ppTerm q d (EPatt p) = prec d 4 (char '#' <+> ppPatt q 2 p)
|
||||
ppTerm q d (EPattType t)=prec d 4 (text "pattern" <+> ppTerm q 0 t)
|
||||
ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> char '.' <> ppLabel l)
|
||||
ppTerm q d (Cn id) = ppIdent id
|
||||
ppTerm q d (Vr id) = ppIdent id
|
||||
ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
|
||||
ppTerm q d (FV es) = "variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
|
||||
ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
|
||||
ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
|
||||
ppTerm q d (Strs es) = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
|
||||
ppTerm q d (EPatt p) = prec d 4 ('#' <+> ppPatt q 2 p)
|
||||
ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t)
|
||||
ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> '.' <> l)
|
||||
ppTerm q d (Cn id) = pp id
|
||||
ppTerm q d (Vr id) = pp id
|
||||
ppTerm q d (Q id) = ppQIdent q id
|
||||
ppTerm q d (QC id) = ppQIdent q id
|
||||
ppTerm q d (Sort id) = ppIdent id
|
||||
ppTerm q d (Sort id) = pp id
|
||||
ppTerm q d (K s) = str s
|
||||
ppTerm q d (EInt n) = int n
|
||||
ppTerm q d (EFloat f) = double f
|
||||
ppTerm q d (EInt n) = pp n
|
||||
ppTerm q d (EFloat f) = pp f
|
||||
ppTerm q d (Meta i) = ppMeta i
|
||||
ppTerm q d (Empty) = text "[]"
|
||||
ppTerm q d (R []) = text "<>" -- to distinguish from {} empty RecType
|
||||
ppTerm q d (R xs) = braces (fsep (punctuate semi [ppLabel l <+>
|
||||
fsep [case mb_t of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty},
|
||||
equals <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
|
||||
ppTerm q d (RecType xs)= braces (fsep (punctuate semi [ppLabel l <+> colon <+> ppTerm q 0 t | (l,t) <- xs]))
|
||||
ppTerm q d (Typed e t) = char '<' <> ppTerm q 0 e <+> colon <+> ppTerm q 0 t <> char '>'
|
||||
ppTerm q d (Empty) = pp "[]"
|
||||
ppTerm q d (R []) = pp "<>" -- to distinguish from {} empty RecType
|
||||
ppTerm q d (R xs) = braces (fsep (punctuate ';' [l <+>
|
||||
fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
|
||||
'=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
|
||||
ppTerm q d (RecType xs)= braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
|
||||
ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
|
||||
ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
|
||||
ppTerm q d (ELincat cat t) = prec d 4 (text "lincat" <+> ppIdent cat <+> ppTerm q 5 t)
|
||||
ppTerm q d (ELin cat t) = prec d 4 (text "lin" <+> ppIdent cat <+> ppTerm q 5 t)
|
||||
ppTerm q d (Error s) = prec d 4 (text "Predef.error" <+> str s)
|
||||
ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
|
||||
ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
|
||||
ppTerm q d (Error s) = prec d 4 ("Predef.error" <+> str s)
|
||||
|
||||
ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> text "->" <+> ppTerm q 0 e
|
||||
ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
|
||||
|
||||
ppCase q (p,e) = ppPatt q 0 p <+> text "=>" <+> ppTerm q 0 e
|
||||
ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
|
||||
|
||||
ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '|' <+> ppPatt q 1 p2)
|
||||
ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '+' <+> ppPatt q 1 p2)
|
||||
ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> char '+' <+> ppPatt q 1 p2)
|
||||
instance Pretty Patt where pp = ppPatt Unqualified 0
|
||||
|
||||
ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2)
|
||||
ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
|
||||
ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
|
||||
ppPatt q d (PC f ps) = if null ps
|
||||
then ppIdent f
|
||||
else prec d 1 (ppIdent f <+> hsep (map (ppPatt q 3) ps))
|
||||
then pp f
|
||||
else prec d 1 (f <+> hsep (map (ppPatt q 3) ps))
|
||||
ppPatt q d (PP f ps) = if null ps
|
||||
then ppQIdent q f
|
||||
else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))
|
||||
ppPatt q d (PRep p) = prec d 1 (ppPatt q 3 p <> char '*')
|
||||
ppPatt q d (PAs f p) = prec d 2 (ppIdent f <> char '@' <> ppPatt q 3 p)
|
||||
ppPatt q d (PNeg p) = prec d 2 (char '-' <> ppPatt q 3 p)
|
||||
ppPatt q d (PChar) = char '?'
|
||||
ppPatt q d (PRep p) = prec d 1 (ppPatt q 3 p <> '*')
|
||||
ppPatt q d (PAs f p) = prec d 2 (f <> '@' <> ppPatt q 3 p)
|
||||
ppPatt q d (PNeg p) = prec d 2 ('-' <> ppPatt q 3 p)
|
||||
ppPatt q d (PChar) = pp '?'
|
||||
ppPatt q d (PChars s) = brackets (str s)
|
||||
ppPatt q d (PMacro id) = char '#' <> ppIdent id
|
||||
ppPatt q d (PM id) = char '#' <> ppQIdent q id
|
||||
ppPatt q d PW = char '_'
|
||||
ppPatt q d (PV id) = ppIdent id
|
||||
ppPatt q d (PInt n) = int n
|
||||
ppPatt q d (PFloat f) = double f
|
||||
ppPatt q d (PMacro id) = '#' <> id
|
||||
ppPatt q d (PM id) = '#' <> ppQIdent q id
|
||||
ppPatt q d PW = pp '_'
|
||||
ppPatt q d (PV id) = pp id
|
||||
ppPatt q d (PInt n) = pp n
|
||||
ppPatt q d (PFloat f) = pp f
|
||||
ppPatt q d (PString s) = str s
|
||||
ppPatt q d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs]))
|
||||
ppPatt q d (PR xs) = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs]))
|
||||
ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)
|
||||
ppPatt q d (PTilde t) = prec d 2 (char '~' <> ppTerm q 6 t)
|
||||
ppPatt q d (PTilde t) = prec d 2 ('~' <> ppTerm q 6 t)
|
||||
|
||||
ppValue :: TermPrintQual -> Int -> Val -> Doc
|
||||
ppValue q d (VGen i x) = ppIdent x <> text "{-" <> int i <> text "-}" ---- latter part for debugging
|
||||
ppValue q d (VGen i x) = x <> "{-" <> i <> "-}" ---- latter part for debugging
|
||||
ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
|
||||
ppValue q d (VCn (_,c)) = ppIdent c
|
||||
ppValue q d (VCn (_,c)) = pp c
|
||||
ppValue q d (VClos env e) = case e of
|
||||
Meta _ -> ppTerm q d e <> ppEnv env
|
||||
_ -> ppTerm q d e ---- ++ prEnv env ---- for debugging
|
||||
ppValue q d (VRecType xs) = braces (hsep (punctuate comma [ppLabel l <> char '=' <> ppValue q 0 v | (l,v) <- xs]))
|
||||
ppValue q d VType = text "Type"
|
||||
ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs]))
|
||||
ppValue q d VType = pp "Type"
|
||||
|
||||
ppConstrs :: Constraints -> [Doc]
|
||||
ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> text "<>" <+> ppValue Unqualified 0 w))
|
||||
ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w))
|
||||
|
||||
ppEnv :: Env -> Doc
|
||||
ppEnv e = hcat (map (\(x,t) -> braces (ppIdent x <> text ":=" <> ppValue Unqualified 0 t)) e)
|
||||
ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
|
||||
|
||||
str s = doubleQuotes (text s)
|
||||
str s = doubleQuotes s
|
||||
|
||||
ppDecl q (_,id,typ)
|
||||
| id == identW = ppTerm q 3 typ
|
||||
| otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ)
|
||||
| otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
|
||||
|
||||
ppDDecl q (_,id,typ)
|
||||
| id == identW = ppTerm q 6 typ
|
||||
| otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ)
|
||||
| otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
|
||||
|
||||
ppQIdent :: TermPrintQual -> QIdent -> Doc
|
||||
ppQIdent q (m,id) =
|
||||
case q of
|
||||
Unqualified -> ppIdent id
|
||||
Qualified -> ppIdent m <> char '.' <> ppIdent id
|
||||
Internal -> ppIdent m <> char '.' <> ppIdent id
|
||||
Unqualified -> pp id
|
||||
Qualified -> m <> '.' <> id
|
||||
Internal -> m <> '.' <> id
|
||||
|
||||
|
||||
ppLabel = ppIdent . label2ident
|
||||
instance Pretty Label where pp = pp . label2ident
|
||||
|
||||
ppOpenSpec (OSimple id) = ppIdent id
|
||||
ppOpenSpec (OQualif id n) = parens (ppIdent id <+> equals <+> ppIdent n)
|
||||
ppOpenSpec (OSimple id) = pp id
|
||||
ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n)
|
||||
|
||||
ppInstSpec (id,n) = parens (ppIdent id <+> equals <+> ppIdent n)
|
||||
ppInstSpec (id,n) = parens (id <+> '=' <+> n)
|
||||
|
||||
ppLocDef q (id, (mbt, e)) =
|
||||
ppIdent id <+>
|
||||
(case mbt of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} <+> equals <+> ppTerm q 0 e) <+> semi
|
||||
id <+>
|
||||
(case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'
|
||||
|
||||
ppBind (Explicit,v) = ppIdent v
|
||||
ppBind (Implicit,v) = braces (ppIdent v)
|
||||
ppBind (Explicit,v) = pp v
|
||||
ppBind (Implicit,v) = braces v
|
||||
|
||||
ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y
|
||||
ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
|
||||
|
||||
ppParams q ps = fsep (intersperse (char '|') (map (ppParam q) ps))
|
||||
ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt)
|
||||
|
||||
ppLocation :: FilePath -> Location -> Doc
|
||||
ppLocation fpath NoLoc = text fpath
|
||||
ppLocation fpath (External p l) = ppLocation p l
|
||||
ppLocation fpath (Local b e)
|
||||
| b == e = text fpath <> colon <> int b
|
||||
| otherwise = text fpath <> colon <> int b <> text "-" <> int e
|
||||
ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
|
||||
ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
|
||||
|
||||
ppProduction (Production fid funid args) =
|
||||
ppFId fid <+> text "->" <+> ppFunId funid <>
|
||||
brackets (hcat (punctuate comma (map (hsep . intersperse (char '|') . map ppFId) args)))
|
||||
ppFId fid <+> "->" <+> ppFunId funid <>
|
||||
brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
|
||||
|
||||
ppSequences q seqsArr
|
||||
| null seqs || q /= Internal = empty
|
||||
| otherwise = text "sequences" <+> char '{' $$
|
||||
| otherwise = "sequences" <+> '{' $$
|
||||
nest 2 (vcat (map ppSeq seqs)) $$
|
||||
char '}'
|
||||
'}'
|
||||
where
|
||||
seqs = Array.assocs seqsArr
|
||||
|
||||
commaPunct f ds = (hcat (punctuate comma (map f ds)))
|
||||
commaPunct f ds = (hcat (punctuate "," (map f ds)))
|
||||
|
||||
prec d1 d2 doc
|
||||
| d1 > d2 = parens doc
|
||||
|
||||
@@ -5,7 +5,7 @@ import GF.Grammar.Printer
|
||||
import GF.Grammar.Lookup
|
||||
import GF.Data.Operations
|
||||
|
||||
import Text.PrettyPrint
|
||||
import GF.Text.Pretty
|
||||
import Data.List (intersperse)
|
||||
|
||||
showTerm :: SourceGrammar -> TermPrintStyle -> TermPrintQual -> Term -> String
|
||||
@@ -13,7 +13,7 @@ showTerm gr sty q t = case sty of
|
||||
TermPrintTable -> render $ vcat [p <+> s | (p,s) <- ppTermTabular gr q t]
|
||||
TermPrintAll -> render $ vcat [ s | (p,s) <- ppTermTabular gr q t]
|
||||
TermPrintList -> renderStyle (style{mode = OneLineMode}) $
|
||||
vcat (punctuate comma [s | (p,s) <- ppTermTabular gr q t])
|
||||
vcat (punctuate ',' [s | (p,s) <- ppTermTabular gr q t])
|
||||
TermPrintOne -> render $ vcat [ s | (p,s) <- take 1 (ppTermTabular gr q t)]
|
||||
TermPrintDefault -> render $ ppTerm q 0 t
|
||||
|
||||
@@ -21,19 +21,19 @@ ppTermTabular :: SourceGrammar -> TermPrintQual -> Term -> [(Doc,Doc)]
|
||||
ppTermTabular gr q = pr where
|
||||
pr t = case t of
|
||||
R rs ->
|
||||
[(ppLabel lab <+> char '.' <+> path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val]
|
||||
[(lab <+> '.' <+> path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val]
|
||||
T _ cs ->
|
||||
[(ppPatt q 0 patt <+> text "=>" <+> path, str) | (patt, val ) <- cs, (path,str) <- pr val]
|
||||
[(ppPatt q 0 patt <+> "=>" <+> path, str) | (patt, val ) <- cs, (path,str) <- pr val]
|
||||
V ty cs ->
|
||||
let pvals = case allParamValues gr ty of
|
||||
Ok pvals -> pvals
|
||||
Bad _ -> map Meta [1..]
|
||||
in [(ppTerm q 0 pval <+> text "=>" <+> path, str) | (pval, val) <- zip pvals cs, (path,str) <- pr val]
|
||||
in [(ppTerm q 0 pval <+> "=>" <+> path, str) | (pval, val) <- zip pvals cs, (path,str) <- pr val]
|
||||
_ -> [(empty,ps t)]
|
||||
ps t = case t of
|
||||
K s -> text s
|
||||
K s -> pp s
|
||||
C s u -> ps s <+> ps u
|
||||
FV ts -> hsep (intersperse (char '/') (map ps ts))
|
||||
FV ts -> hsep (intersperse (pp '/') (map ps ts))
|
||||
_ -> ppTerm q 0 t
|
||||
|
||||
data TermPrintStyle
|
||||
|
||||
Reference in New Issue
Block a user