-
Notifications
You must be signed in to change notification settings - Fork 145
/
IdPrint.hs
155 lines (135 loc) · 5.39 KB
/
IdPrint.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
module IdPrint(
pvpPId, pvpId, pfpId, ppId, ppConId, ppVarId, mkUId,
getBSVIdString
) where
import Data.Char(isDigit)
import Id
import Util(dbgLevel)
import Lex(isIdChar, isSym)
import ErrorUtil(internalError)
import PreStrings(fsEmpty, fsPrelude, fsPreludeBSV)
import Classic
import PPrint
import PVPrint
import IOUtil(progArgs)
show_qual :: Bool
show_qual = "-show-qualifiers" `elem` progArgs
local_show :: Id -> String
local_show id =
let
pos = getIdPosition id
mfs = getIdQualString id
fs = getIdBaseString id
str = show pos ++ " " ++
show mfs ++ " " ++
show fs
in str
instance PPrint Id where
pPrint PDDebug _ i = text (local_show i)
-- <> text(" props: " ++ show (getIdProps i ))
pPrint _ _ i =
if (dbgLevel >= 1)
then text ((getIdString i) ++
"_" ++
(createPositionString (getIdPosition i)))
else text (getIdString i)
-- pPrint _ _ i = text ((getIdString i) ++ "|" ++ (show (getIdPosition i)) ++ "|" ++ (show (getIdProps i)))
-- pPrint _ _ i = text ((getIdString i) ++ "|" ++ (show (getIdProps i)))
-- --------------------
instance PVPrint Id where
pvPrint PDDebug _ i = text (show i)
pvPrint PDNoqual _ i = text (getIdBaseString i)
pvPrint _ _ i =
let s = getBSVIdString i
in text (if s=="not" then "!" else s)
pvpPId :: PDetail -> Id -> Doc
pvpPId d i =
case getIdBaseString i of
_ -> pvpId d i
pvpId :: PDetail -> Id -> Doc
pvpId PDDebug i = pvPrint PDDebug 0 i
pvpId PDNoqual i = pvPrint PDNoqual 0 i
pvpId d i =
case getIdBaseString i of
"->" -> text "(->)"
":=" -> text "<="
"not" -> text "!"
s@(c:_) | isDigit c -> text s
c:_ | isIdChar c -> text (getBSVIdString i)
_ -> text ("("++getBSVIdString i++")")
-- hack: suppress the package name for operators
getBSVIdString :: Id -> String
getBSVIdString a = (getBSVIdStringz a)
getBSVIdStringz :: Id -> String
getBSVIdStringz a
| getIdBase a == fsEmpty = internalError "CVPrint.getIdStr: empty identifier"
| getIdQual a == fsEmpty = getIdBaseStringz a
| not (isIdChar (head (getIdBaseStringz a))) = getIdBaseStringz a -- operators
| (not show_qual) && (getIdQual a == fsPrelude) =
getIdBaseStringz a -- suppress "Prelude::" unless flag is on
| (not show_qual) && (getIdQual a == fsPreludeBSV) =
getIdBaseStringz a -- suppress "Prelude::" unless flag is on
| otherwise = getIdQualString a ++ "::" ++ getIdBaseStringz a
getIdBaseStringz :: Id -> String
getIdBaseStringz a =
let s = getIdBaseString a
in if (not (isEse()) || length s < 7) then s
else if (take 7 s == "ese_id_" || take 7 s == "Ese_id_") then drop 7 s
else s
-- --------------------
pfpId :: PDetail -> Id -> Doc
pfpId = if isClassic() then ppId else pvpId
ppId :: PDetail -> Id -> Doc
ppId PDDebug i = pPrint PDDebug 0 i
ppId d i =
if (dbgLevel >= 1)
then case (getIdBaseString i) of
"->" -> text "(->)" -- arrow
s@(c:_) | isDigit c -> text( s ++ "_" ++ (createPositionString (getIdPosition i)))
c:_ | isIdChar c -> text ((getIdString i) ++ "_" ++ (createPositionString (getIdPosition i)))
'$':c:_ | isIdChar c -> text (getIdString i) -- task names
_ -> text ("(" ++ (getIdString i) ++ "_" ++ (createPositionString (getIdPosition i)))
else case (getIdBaseString i) of
"->" -> text "(->)" -- arrow
s@(c:_) | isDigit c -> text s -- numbers
c:_ | isIdChar c -> text (getIdString i) -- identifiers
'$':c:_ | isIdChar c -> text (getIdString i) -- task names
_ -> text ("("++getIdString i++")") -- infix operators
ppVarId :: PDetail -> Id -> Doc
ppVarId PDDebug i = pPrint PDDebug 0 i
ppVarId d i =
if (dbgLevel >= 1)
then case (getIdBaseString i) of
s | all isSym s -> text ("("++ (getIdStringOp i) ++ (createPositionString (getIdPosition i)) ++
")") -- infix operators
'$':c:_ | isIdChar c -> text ((getIdStringVar i) ++ (createPositionString (getIdPosition i)))
_ -> text ((getIdStringVar i) ++ (createPositionString (getIdPosition i)))
else case (getIdBaseString i) of
s | all isSym s -> text ("("++getIdStringOp i ++ ")") -- infix operators
'$':c:_ | isIdChar c -> text (getIdStringVar i) -- task names
_ -> text (getIdStringVar i)
ppConId :: PDetail -> Id -> Doc
ppConId PDDebug i = pPrint PDDebug 0 i
ppConId d i = -- text ( "props:" ++ show (getIdProps i)) <>
case (getIdBaseString i) of
"->" -> text "(->)" -- arrow
s@(c:_) | all isDigit s -> text s -- numbers
_ -> text (getIdStringCon i) -- constructor-identifiers
-- These used to encode properties in .bi files
getIdStringCon :: Id -> String
getIdStringCon = getIdString
getIdStringVar :: Id -> String
getIdStringVar = getIdString
getIdStringOp :: Id -> String
getIdStringOp = getIdString
-- --------------------
instance PPrint IdProp where
pPrint d _ (IdPInlinedPositions poss) =
pparen True (text "IdPInlinedPositions" <+> pPrint d 0 poss)
pPrint _ _ prop = text (show prop)
{-
instance PVPrint IdProp where
pvPrint d _ (IdPInlinedPositions poss) =
pparen True (text "IdPInlinedPositions" <+> pvPrint d 0 poss)
pvPrint _ _ prop = text (show prop)
-}