mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-17 23:22:51 -06:00
Replace tabs for whitespace in source code
This commit is contained in:
John J. Camilleri
@@ -45,12 +45,12 @@ data LincatDef = LincatDef CatId LinType deriving Show
|
||||
data LinDef = LinDef FunId [VarId] LinValue deriving Show
|
||||
|
||||
-- | Linearization type, RHS of @lincat@
|
||||
data LinType = FloatType
|
||||
| IntType
|
||||
data LinType = FloatType
|
||||
| IntType
|
||||
| ParamType ParamType
|
||||
| RecordType [RecordRowType]
|
||||
| StrType
|
||||
| TableType LinType LinType
|
||||
| StrType
|
||||
| TableType LinType LinType
|
||||
| TupleType [LinType]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
@@ -60,7 +60,7 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
|
||||
data LinValue = ConcatValue LinValue LinValue
|
||||
| LiteralValue LinLiteral
|
||||
| ErrorValue String
|
||||
| ParamConstant ParamValue
|
||||
| ParamConstant ParamValue
|
||||
| PredefValue PredefId
|
||||
| RecordValue [RecordRowValue]
|
||||
| TableValue LinType [TableRowValue]
|
||||
@@ -74,9 +74,9 @@ data LinValue = ConcatValue LinValue LinValue
|
||||
| CommentedValue String LinValue
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data LinLiteral = FloatConstant Float
|
||||
| IntConstant Int
|
||||
| StrConstant String
|
||||
data LinLiteral = FloatConstant Float
|
||||
| IntConstant Int
|
||||
| StrConstant String
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data LinPattern = ParamPattern ParamPattern
|
||||
@@ -107,7 +107,7 @@ newtype PredefId = PredefId Id deriving (Eq,Ord,Show)
|
||||
newtype LabelId = LabelId Id deriving (Eq,Ord,Show)
|
||||
data VarValueId = VarValueId QualId deriving (Eq,Ord,Show)
|
||||
|
||||
-- | Name of param type or param value
|
||||
-- | Name of param type or param value
|
||||
newtype ParamId = ParamId QualId deriving (Eq,Ord,Show)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@@ -250,7 +250,7 @@ instance PPA LinLiteral where
|
||||
FloatConstant f -> pp f
|
||||
IntConstant n -> pp n
|
||||
StrConstant s -> doubleQuotes s -- hmm
|
||||
|
||||
|
||||
instance RhsSeparator LinValue where rhsSep _ = pp "="
|
||||
|
||||
instance Pretty LinPattern where
|
||||
@@ -265,7 +265,7 @@ instance PPA LinPattern where
|
||||
ParamPattern pv -> ppA pv
|
||||
RecordPattern r -> block r
|
||||
TuplePattern ps -> "<"<>punctuate "," ps<>">"
|
||||
WildPattern -> pp "_"
|
||||
WildPattern -> pp "_"
|
||||
|
||||
instance RhsSeparator LinPattern where rhsSep _ = pp "="
|
||||
|
||||
|
||||
@@ -267,7 +267,7 @@ type AlexInput2 = (AlexInput,AlexInput)
|
||||
|
||||
data ParseResult a
|
||||
= POk AlexInput2 a
|
||||
| PFailed Posn -- The position of the error
|
||||
| PFailed Posn -- The position of the error
|
||||
String -- The error message
|
||||
|
||||
newtype P a = P { unP :: AlexInput2 -> ParseResult a }
|
||||
|
||||
@@ -6,7 +6,7 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/27 13:21:53 $
|
||||
-- > CVS $Date: 2005/10/27 13:21:53 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.15 $
|
||||
--
|
||||
@@ -20,17 +20,17 @@ module GF.Grammar.Lookup (
|
||||
lookupOrigInfo,
|
||||
allOrigInfos,
|
||||
lookupResDef, lookupResDefLoc,
|
||||
lookupResType,
|
||||
lookupResType,
|
||||
lookupOverload,
|
||||
lookupOverloadTypes,
|
||||
lookupParamValues,
|
||||
lookupParamValues,
|
||||
allParamValues,
|
||||
lookupAbsDef,
|
||||
lookupLincat,
|
||||
lookupAbsDef,
|
||||
lookupLincat,
|
||||
lookupFunType,
|
||||
lookupCatContext,
|
||||
allOpers, allOpersTo
|
||||
) where
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Infra.Ident
|
||||
@@ -69,7 +69,7 @@ lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x)
|
||||
lookupResDefLoc gr (m,c)
|
||||
| isPredefCat c = fmap noLoc (lock c defLinType)
|
||||
| otherwise = look m c
|
||||
where
|
||||
where
|
||||
look m c = do
|
||||
info <- lookupQIdentInfo gr (m,c)
|
||||
case info of
|
||||
@@ -77,7 +77,7 @@ lookupResDefLoc gr (m,c)
|
||||
ResOper _ Nothing -> return (noLoc (Q (m,c)))
|
||||
CncCat (Just (L l ty)) _ _ _ _ -> fmap (L l) (lock c ty)
|
||||
CncCat _ _ _ _ _ -> fmap noLoc (lock c defLinType)
|
||||
|
||||
|
||||
CncFun (Just (cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr)
|
||||
CncFun _ (Just ltr) _ _ -> return ltr
|
||||
|
||||
@@ -95,7 +95,7 @@ lookupResType gr (m,c) = do
|
||||
-- used in reused concrete
|
||||
CncCat _ _ _ _ _ -> return typeType
|
||||
CncFun (Just (cat,cont,val)) _ _ _ -> do
|
||||
val' <- lock cat val
|
||||
val' <- lock cat val
|
||||
return $ mkProd cont val' []
|
||||
AnyInd _ n -> lookupResType gr (n,c)
|
||||
ResParam _ _ -> return typePType
|
||||
@@ -111,7 +111,7 @@ lookupOverloadTypes gr id@(m,c) = do
|
||||
-- used in reused concrete
|
||||
CncCat _ _ _ _ _ -> ret typeType
|
||||
CncFun (Just (cat,cont,val)) _ _ _ -> do
|
||||
val' <- lock cat val
|
||||
val' <- lock cat val
|
||||
ret $ mkProd cont val' []
|
||||
ResParam _ _ -> ret typePType
|
||||
ResValue (L _ t) -> ret t
|
||||
@@ -130,8 +130,8 @@ lookupOverload gr (m,c) = do
|
||||
case info of
|
||||
ResOverload os tysts -> do
|
||||
tss <- mapM (\x -> lookupOverload gr (x,c)) os
|
||||
return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) |
|
||||
(L _ ty,L _ tr) <- tysts] ++
|
||||
return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) |
|
||||
(L _ ty,L _ tr) <- tysts] ++
|
||||
concat tss
|
||||
|
||||
AnyInd _ n -> lookupOverload gr (n,c)
|
||||
@@ -216,7 +216,7 @@ lookupCatContext gr m c = do
|
||||
-- notice that it only gives the modules that are reachable and the opers that are included
|
||||
|
||||
allOpers :: Grammar -> [(QIdent,Type,Location)]
|
||||
allOpers gr =
|
||||
allOpers gr =
|
||||
[((m,op),typ,loc) |
|
||||
(m,mi) <- maybe [] (allExtends gr) (greatestResource gr),
|
||||
(op,info) <- Map.toList (jments mi),
|
||||
|
||||
@@ -5,18 +5,19 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/12 12:38:29 $
|
||||
-- > CVS $Date: 2005/10/12 12:38:29 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.7 $
|
||||
--
|
||||
-- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.PatternMatch (matchPattern,
|
||||
testOvershadow,
|
||||
findMatch,
|
||||
measurePatt
|
||||
) where
|
||||
module GF.Grammar.PatternMatch (
|
||||
matchPattern,
|
||||
testOvershadow,
|
||||
findMatch,
|
||||
measurePatt
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Grammar
|
||||
@@ -30,7 +31,7 @@ import GF.Text.Pretty
|
||||
--import Debug.Trace
|
||||
|
||||
matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
|
||||
matchPattern pts term =
|
||||
matchPattern pts term =
|
||||
if not (isInConstantForm term)
|
||||
then raise (render ("variables occur in" <+> pp term))
|
||||
else do
|
||||
@@ -61,15 +62,15 @@ testOvershadow pts vs = do
|
||||
findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
|
||||
findMatch cases terms = case cases of
|
||||
[] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms)))
|
||||
(patts,_):_ | length patts /= length terms ->
|
||||
raise (render ("wrong number of args for patterns :" <+> hsep patts <+>
|
||||
(patts,_):_ | length patts /= length 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
|
||||
|
||||
tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
|
||||
tryMatch (p,t) = do
|
||||
tryMatch (p,t) = do
|
||||
t' <- termForm t
|
||||
trym p t'
|
||||
where
|
||||
@@ -83,26 +84,26 @@ tryMatch (p,t) = do
|
||||
(PString s, ([],K i,[])) | s==i -> return []
|
||||
(PInt s, ([],EInt i,[])) | s==i -> return []
|
||||
(PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
|
||||
(PC p pp, ([], Con f, tt)) |
|
||||
(PC p pp, ([], Con f, tt)) |
|
||||
p `eqStrIdent` f && length pp == length tt ->
|
||||
do matches <- mapM tryMatch (zip pp tt)
|
||||
return (concat matches)
|
||||
|
||||
(PP (q,p) pp, ([], QC (r,f), tt)) |
|
||||
(PP (q,p) pp, ([], QC (r,f), tt)) |
|
||||
-- q `eqStrIdent` r && --- not for inherited AR 10/10/2005
|
||||
p `eqStrIdent` f && length pp == length tt ->
|
||||
do matches <- mapM tryMatch (zip pp tt)
|
||||
return (concat matches)
|
||||
---- hack for AppPredef bug
|
||||
(PP (q,p) pp, ([], Q (r,f), tt)) |
|
||||
-- q `eqStrIdent` r && ---
|
||||
(PP (q,p) pp, ([], Q (r,f), tt)) |
|
||||
-- q `eqStrIdent` r && ---
|
||||
p `eqStrIdent` f && length pp == length tt ->
|
||||
do matches <- mapM tryMatch (zip pp tt)
|
||||
return (concat matches)
|
||||
|
||||
(PR r, ([],R r',[])) |
|
||||
all (`elem` map fst r') (map fst r) ->
|
||||
do matches <- mapM tryMatch
|
||||
do matches <- mapM tryMatch
|
||||
[(p,snd a) | (l,p) <- r, let Just a = lookup l r']
|
||||
return (concat matches)
|
||||
(PT _ p',_) -> trym p' t'
|
||||
@@ -125,7 +126,7 @@ tryMatch (p,t) = do
|
||||
(PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s
|
||||
|
||||
(PRep p1, ([],K s, [])) -> checks [
|
||||
trym (foldr (const (PSeq p1)) (PString "")
|
||||
trym (foldr (const (PSeq p1)) (PString "")
|
||||
[1..n]) t' | n <- [0 .. length s]
|
||||
] >>
|
||||
return []
|
||||
|
||||
@@ -1,365 +1,364 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : GF.Grammar.Printer
|
||||
-- Maintainer : Krasimir Angelov
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module GF.Grammar.Printer
|
||||
( -- ** Pretty printing
|
||||
TermPrintQual(..)
|
||||
, ppModule
|
||||
, ppJudgement
|
||||
, ppParams
|
||||
, ppTerm
|
||||
, ppPatt
|
||||
, ppValue
|
||||
, ppConstrs
|
||||
, ppQIdent
|
||||
, ppMeta
|
||||
, getAbs
|
||||
) where
|
||||
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option
|
||||
import GF.Grammar.Values
|
||||
import GF.Grammar.Grammar
|
||||
|
||||
import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
|
||||
|
||||
import GF.Text.Pretty
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.List (intersperse)
|
||||
import qualified Data.Map as Map
|
||||
--import qualified Data.IntMap as IntMap
|
||||
--import qualified Data.Set as Set
|
||||
import qualified Data.Array.IArray as Array
|
||||
|
||||
data TermPrintQual
|
||||
= Terse | Unqualified | Qualified | Internal
|
||||
deriving Eq
|
||||
|
||||
instance Pretty Grammar where
|
||||
pp = vcat . map (ppModule Qualified) . modules
|
||||
|
||||
ppModule :: TermPrintQual -> SourceModule -> Doc
|
||||
ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
|
||||
hdr $$
|
||||
nest 2 (ppOptions opts $$
|
||||
vcat (map (ppJudgement q) (Map.toList jments)) $$
|
||||
maybe empty (ppSequences q) mseqs) $$
|
||||
ftr
|
||||
where
|
||||
hdr = complModDoc <+> modTypeDoc <+> '=' <+>
|
||||
hsep (intersperse (pp "**") $
|
||||
filter (not . isEmpty) $ [ commaPunct ppExtends exts
|
||||
, maybe empty ppWith with
|
||||
, if null opens
|
||||
then pp '{'
|
||||
else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{'
|
||||
])
|
||||
|
||||
ftr = '}'
|
||||
|
||||
complModDoc =
|
||||
case mstat of
|
||||
MSComplete -> empty
|
||||
MSIncomplete -> pp "incomplete"
|
||||
|
||||
modTypeDoc =
|
||||
case mtype of
|
||||
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 ) = 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) <+> "with" <+> commaPunct ppInstSpec opens
|
||||
|
||||
ppOptions opts =
|
||||
"flags" $$
|
||||
nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
|
||||
|
||||
ppJudgement q (id, AbsCat pcont ) =
|
||||
"cat" <+> id <+>
|
||||
(case pcont of
|
||||
Just (L _ cont) -> hsep (map (ppDecl q) cont)
|
||||
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) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case pexp of
|
||||
Just [] -> empty
|
||||
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 _) =
|
||||
"param" <+> id <+>
|
||||
(case pparams of
|
||||
Just (L _ ps) -> '=' <+> ppParams q ps
|
||||
_ -> empty) <+> ';'
|
||||
ppJudgement q (id, ResValue pvalue) =
|
||||
"-- param constructor" <+> id <+> ':' <+>
|
||||
(case pvalue of
|
||||
(L _ ty) -> ppTerm q 0 ty) <+> ';'
|
||||
ppJudgement q (id, ResOper ptype pexp) =
|
||||
"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) =
|
||||
"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) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case pdef of
|
||||
Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case pref of
|
||||
Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case pprn of
|
||||
Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case (mpmcfg,q) of
|
||||
(Just (PMCFG prods funs),Internal)
|
||||
-> "pmcfg" <+> id <+> '=' <+> '{' $$
|
||||
nest 2 (vcat (map ppProduction prods) $$
|
||||
' ' $$
|
||||
vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
|
||||
parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
|
||||
(Array.assocs funs))) $$
|
||||
'}'
|
||||
_ -> empty)
|
||||
ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) =
|
||||
(case pdef of
|
||||
Just (L _ e) -> let (xs,e') = getAbs e
|
||||
in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case pprn of
|
||||
Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case (mpmcfg,q) of
|
||||
(Just (PMCFG prods funs),Internal)
|
||||
-> "pmcfg" <+> id <+> '=' <+> '{' $$
|
||||
nest 2 (vcat (map ppProduction prods) $$
|
||||
' ' $$
|
||||
vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
|
||||
parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
|
||||
(Array.assocs funs))) $$
|
||||
'}'
|
||||
_ -> empty)
|
||||
ppJudgement q (id, AnyInd cann mid) =
|
||||
case q of
|
||||
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 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e')
|
||||
ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of
|
||||
([],_) -> "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 <+> "->" <+> 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 ("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 "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 "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
|
||||
ppTerm q d (FV es) = prec d 4 ("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) = pp id
|
||||
ppTerm q d (K s) = str s
|
||||
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) = 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)
|
||||
| q == Terse = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
|
||||
[cat] -> pp cat
|
||||
_ -> doc
|
||||
| otherwise = doc
|
||||
where
|
||||
doc = 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 ("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) <+> "->" <+> ppTerm q 0 e
|
||||
|
||||
ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
|
||||
|
||||
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 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 <> '*')
|
||||
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) = '#' <> 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 ';' [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 ('~' <> ppTerm q 6 t)
|
||||
|
||||
ppValue :: TermPrintQual -> Int -> Val -> Doc
|
||||
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)) = 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 ',' [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 <+> "<>" <+> ppValue Unqualified 0 w))
|
||||
|
||||
ppEnv :: Env -> Doc
|
||||
ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
|
||||
|
||||
str s = doubleQuotes s
|
||||
|
||||
ppDecl q (_,id,typ)
|
||||
| id == identW = ppTerm q 3 typ
|
||||
| otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
|
||||
|
||||
ppDDecl q (_,id,typ)
|
||||
| id == identW = ppTerm q 6 typ
|
||||
| otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
|
||||
|
||||
ppQIdent :: TermPrintQual -> QIdent -> Doc
|
||||
ppQIdent q (m,id) =
|
||||
case q of
|
||||
Terse -> pp id
|
||||
Unqualified -> pp id
|
||||
Qualified -> m <> '.' <> id
|
||||
Internal -> m <> '.' <> id
|
||||
|
||||
|
||||
instance Pretty Label where pp = pp . label2ident
|
||||
|
||||
ppOpenSpec (OSimple id) = pp id
|
||||
ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n)
|
||||
|
||||
ppInstSpec (id,n) = parens (id <+> '=' <+> n)
|
||||
|
||||
ppLocDef q (id, (mbt, e)) =
|
||||
id <+>
|
||||
(case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'
|
||||
|
||||
ppBind (Explicit,v) = pp v
|
||||
ppBind (Implicit,v) = braces v
|
||||
|
||||
ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
|
||||
|
||||
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 <+> "->" <+> ppFunId funid <>
|
||||
brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
|
||||
|
||||
ppSequences q seqsArr
|
||||
| null seqs || q /= Internal = empty
|
||||
| otherwise = "sequences" <+> '{' $$
|
||||
nest 2 (vcat (map ppSeq seqs)) $$
|
||||
'}'
|
||||
where
|
||||
seqs = Array.assocs seqsArr
|
||||
|
||||
commaPunct f ds = (hcat (punctuate "," (map f ds)))
|
||||
|
||||
prec d1 d2 doc
|
||||
| d1 > d2 = parens doc
|
||||
| otherwise = doc
|
||||
|
||||
getAbs :: Term -> ([(BindType,Ident)], Term)
|
||||
getAbs (Abs bt v e) = let (xs,e') = getAbs e
|
||||
in ((bt,v):xs,e')
|
||||
getAbs e = ([],e)
|
||||
|
||||
getCTable :: Term -> ([Ident], Term)
|
||||
getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e
|
||||
in (v:vs,e')
|
||||
getCTable (T TRaw [(PW, e)]) = let (vs,e') = getCTable e
|
||||
in (identW:vs,e')
|
||||
getCTable e = ([],e)
|
||||
|
||||
getLet :: Term -> ([LocalDef], Term)
|
||||
getLet (Let l e) = let (ls,e') = getLet e
|
||||
in (l:ls,e')
|
||||
getLet e = ([],e)
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : GF.Grammar.Printer
|
||||
-- Maintainer : Krasimir Angelov
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module GF.Grammar.Printer
|
||||
( -- ** Pretty printing
|
||||
TermPrintQual(..)
|
||||
, ppModule
|
||||
, ppJudgement
|
||||
, ppParams
|
||||
, ppTerm
|
||||
, ppPatt
|
||||
, ppValue
|
||||
, ppConstrs
|
||||
, ppQIdent
|
||||
, ppMeta
|
||||
, getAbs
|
||||
) where
|
||||
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option
|
||||
import GF.Grammar.Values
|
||||
import GF.Grammar.Grammar
|
||||
|
||||
import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
|
||||
|
||||
import GF.Text.Pretty
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.List (intersperse)
|
||||
import qualified Data.Map as Map
|
||||
--import qualified Data.IntMap as IntMap
|
||||
--import qualified Data.Set as Set
|
||||
import qualified Data.Array.IArray as Array
|
||||
|
||||
data TermPrintQual
|
||||
= Terse | Unqualified | Qualified | Internal
|
||||
deriving Eq
|
||||
|
||||
instance Pretty Grammar where
|
||||
pp = vcat . map (ppModule Qualified) . modules
|
||||
|
||||
ppModule :: TermPrintQual -> SourceModule -> Doc
|
||||
ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
|
||||
hdr $$
|
||||
nest 2 (ppOptions opts $$
|
||||
vcat (map (ppJudgement q) (Map.toList jments)) $$
|
||||
maybe empty (ppSequences q) mseqs) $$
|
||||
ftr
|
||||
where
|
||||
hdr = complModDoc <+> modTypeDoc <+> '=' <+>
|
||||
hsep (intersperse (pp "**") $
|
||||
filter (not . isEmpty) $ [ commaPunct ppExtends exts
|
||||
, maybe empty ppWith with
|
||||
, if null opens
|
||||
then pp '{'
|
||||
else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{'
|
||||
])
|
||||
|
||||
ftr = '}'
|
||||
|
||||
complModDoc =
|
||||
case mstat of
|
||||
MSComplete -> empty
|
||||
MSIncomplete -> pp "incomplete"
|
||||
|
||||
modTypeDoc =
|
||||
case mtype of
|
||||
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 ) = 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) <+> "with" <+> commaPunct ppInstSpec opens
|
||||
|
||||
ppOptions opts =
|
||||
"flags" $$
|
||||
nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
|
||||
|
||||
ppJudgement q (id, AbsCat pcont ) =
|
||||
"cat" <+> id <+>
|
||||
(case pcont of
|
||||
Just (L _ cont) -> hsep (map (ppDecl q) cont)
|
||||
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) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case pexp of
|
||||
Just [] -> empty
|
||||
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 _) =
|
||||
"param" <+> id <+>
|
||||
(case pparams of
|
||||
Just (L _ ps) -> '=' <+> ppParams q ps
|
||||
_ -> empty) <+> ';'
|
||||
ppJudgement q (id, ResValue pvalue) =
|
||||
"-- param constructor" <+> id <+> ':' <+>
|
||||
(case pvalue of
|
||||
(L _ ty) -> ppTerm q 0 ty) <+> ';'
|
||||
ppJudgement q (id, ResOper ptype pexp) =
|
||||
"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) =
|
||||
"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) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case pdef of
|
||||
Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case pref of
|
||||
Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case pprn of
|
||||
Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case (mpmcfg,q) of
|
||||
(Just (PMCFG prods funs),Internal)
|
||||
-> "pmcfg" <+> id <+> '=' <+> '{' $$
|
||||
nest 2 (vcat (map ppProduction prods) $$
|
||||
' ' $$
|
||||
vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
|
||||
parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
|
||||
(Array.assocs funs))) $$
|
||||
'}'
|
||||
_ -> empty)
|
||||
ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) =
|
||||
(case pdef of
|
||||
Just (L _ e) -> let (xs,e') = getAbs e
|
||||
in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case pprn of
|
||||
Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
|
||||
Nothing -> empty) $$
|
||||
(case (mpmcfg,q) of
|
||||
(Just (PMCFG prods funs),Internal)
|
||||
-> "pmcfg" <+> id <+> '=' <+> '{' $$
|
||||
nest 2 (vcat (map ppProduction prods) $$
|
||||
' ' $$
|
||||
vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
|
||||
parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
|
||||
(Array.assocs funs))) $$
|
||||
'}'
|
||||
_ -> empty)
|
||||
ppJudgement q (id, AnyInd cann mid) =
|
||||
case q of
|
||||
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 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e')
|
||||
ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of
|
||||
([],_) -> "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 <+> "->" <+> 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 ("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 "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 "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
|
||||
ppTerm q d (FV es) = prec d 4 ("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) = pp id
|
||||
ppTerm q d (K s) = str s
|
||||
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) = 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)
|
||||
| q == Terse = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
|
||||
[cat] -> pp cat
|
||||
_ -> doc
|
||||
| otherwise = doc
|
||||
where
|
||||
doc = 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 ("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) <+> "->" <+> ppTerm q 0 e
|
||||
|
||||
ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
|
||||
|
||||
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 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 <> '*')
|
||||
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) = '#' <> 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 ';' [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 ('~' <> ppTerm q 6 t)
|
||||
|
||||
ppValue :: TermPrintQual -> Int -> Val -> Doc
|
||||
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)) = 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 ',' [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 <+> "<>" <+> ppValue Unqualified 0 w))
|
||||
|
||||
ppEnv :: Env -> Doc
|
||||
ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
|
||||
|
||||
str s = doubleQuotes s
|
||||
|
||||
ppDecl q (_,id,typ)
|
||||
| id == identW = ppTerm q 3 typ
|
||||
| otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
|
||||
|
||||
ppDDecl q (_,id,typ)
|
||||
| id == identW = ppTerm q 6 typ
|
||||
| otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
|
||||
|
||||
ppQIdent :: TermPrintQual -> QIdent -> Doc
|
||||
ppQIdent q (m,id) =
|
||||
case q of
|
||||
Terse -> pp id
|
||||
Unqualified -> pp id
|
||||
Qualified -> m <> '.' <> id
|
||||
Internal -> m <> '.' <> id
|
||||
|
||||
|
||||
instance Pretty Label where pp = pp . label2ident
|
||||
|
||||
ppOpenSpec (OSimple id) = pp id
|
||||
ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n)
|
||||
|
||||
ppInstSpec (id,n) = parens (id <+> '=' <+> n)
|
||||
|
||||
ppLocDef q (id, (mbt, e)) =
|
||||
id <+>
|
||||
(case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'
|
||||
|
||||
ppBind (Explicit,v) = pp v
|
||||
ppBind (Implicit,v) = braces v
|
||||
|
||||
ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
|
||||
|
||||
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 <+> "->" <+> ppFunId funid <>
|
||||
brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
|
||||
|
||||
ppSequences q seqsArr
|
||||
| null seqs || q /= Internal = empty
|
||||
| otherwise = "sequences" <+> '{' $$
|
||||
nest 2 (vcat (map ppSeq seqs)) $$
|
||||
'}'
|
||||
where
|
||||
seqs = Array.assocs seqsArr
|
||||
|
||||
commaPunct f ds = (hcat (punctuate "," (map f ds)))
|
||||
|
||||
prec d1 d2 doc
|
||||
| d1 > d2 = parens doc
|
||||
| otherwise = doc
|
||||
|
||||
getAbs :: Term -> ([(BindType,Ident)], Term)
|
||||
getAbs (Abs bt v e) = let (xs,e') = getAbs e
|
||||
in ((bt,v):xs,e')
|
||||
getAbs e = ([],e)
|
||||
|
||||
getCTable :: Term -> ([Ident], Term)
|
||||
getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e
|
||||
in (v:vs,e')
|
||||
getCTable (T TRaw [(PW, e)]) = let (vs,e') = getCTable e
|
||||
in (identW:vs,e')
|
||||
getCTable e = ([],e)
|
||||
|
||||
getLet :: Term -> ([LocalDef], Term)
|
||||
getLet (Let l e) = let (ls,e') = getLet e
|
||||
in (l:ls,e')
|
||||
getLet e = ([],e)
|
||||
|
||||
@@ -5,22 +5,23 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:22:32 $
|
||||
-- > CVS $Date: 2005/04/21 16:22:32 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.7 $
|
||||
--
|
||||
-- (Description of the module)
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.Values (-- ** Values used in TC type checking
|
||||
Val(..), Env,
|
||||
-- ** Annotated tree used in editing
|
||||
module GF.Grammar.Values (
|
||||
-- ** Values used in TC type checking
|
||||
Val(..), Env,
|
||||
-- ** Annotated tree used in editing
|
||||
Binds, Constraints, MetaSubst,
|
||||
-- ** For TC
|
||||
valAbsInt, valAbsFloat, valAbsString, vType,
|
||||
isPredefCat,
|
||||
eType,
|
||||
) where
|
||||
-- ** For TC
|
||||
valAbsInt, valAbsFloat, valAbsString, vType,
|
||||
isPredefCat,
|
||||
eType,
|
||||
) where
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Grammar
|
||||
|
||||
Reference in New Issue
Block a user