Skip to content

Commit 5881e28

Browse files
srghmasrghma
authored
Merge pull request #8 from srghma/master
appendUnderscoreIfReserved
2 parents cc33695 + 09cc250 commit 5881e28

File tree

11 files changed

+170
-89
lines changed

11 files changed

+170
-89
lines changed

‎src/Language/PS/CST.purs

+3-2
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
module Language.PS.CST
2-
( module Types
2+
( module Export
33
) where
44

5-
import Language.PS.CST.Types (AdoBlock, Binder(..), CaseOf, ClassFundep(..), ClassHead, Comments(..), Constraint(..), DataCtor(..), DataHead(..), DataMembers(..), DeclDeriveType(..), Declaration(..), DoBlock, DoStatement(..), Export(..), Expr(..), Fixity(..), FixityFields, FixityFieldsRow, FixityOp(..), Foreign(..), Guarded(..), GuardedExpr, Ident(..), IfThenElse, Import(..), ImportDecl(..), Instance, InstanceBinding(..), InstanceHead, Kind(..), Label(..), Lambda, LetBinding(..), LetIn, Module(..), ModuleName(..), OpName(..), OpNameType_TypeOpName, OpNameType_ValueOpName, PatternGuard, ProperName(..), ProperNameType_ClassName, ProperNameType_ConstructorName, ProperNameType_KindName, ProperNameType_Namespace, ProperNameType_TypeName, QualifiedName(..), RecordAccessor, RecordLabeled(..), RecordUpdate(..), Row(..), Type(..), TypeVarBinding(..), ValueBindingFields, ValueBindingFieldsRow, Where, (====>), (====>>), (====>>>), kind OpNameType, kind ProperNameType) as Types
5+
import Language.PS.CST.Types (AdoBlock, Binder(..), CaseOf, ClassFundep(..), ClassHead, Comments(..), Constraint(..), DataCtor(..), DataHead(..), DataMembers(..), DeclDeriveType(..), Declaration(..), DoBlock, DoStatement(..), Export(..), Expr(..), Fixity(..), FixityFields, FixityFieldsRow, FixityOp(..), Foreign(..), Guarded(..), GuardedExpr, Ident(..), IfThenElse, Import(..), ImportDecl(..), Instance, InstanceBinding(..), InstanceHead, Kind(..), Label(..), Lambda, LetBinding(..), LetIn, Module(..), ModuleName(..), OpName(..), OpNameType_TypeOpName, OpNameType_ValueOpName, PatternGuard, ProperName(..), ProperNameType_ClassName, ProperNameType_ConstructorName, ProperNameType_KindName, ProperNameType_Namespace, ProperNameType_TypeName, QualifiedName(..), RecordAccessor, RecordLabeled(..), RecordUpdate(..), Row(..), Type(..), TypeVarBinding(..), ValueBindingFields, ValueBindingFieldsRow, Where, (====>), (====>>), (====>>>), kind OpNameType, kind ProperNameType) as Export
6+
import Language.PS.CST.ReservedNames (reservedNames, appendUnderscoreIfReserved) as Export

‎src/Language/PS/CST/Printers.purs

+29-26
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,15 @@
11
module Language.PS.CST.Printers where
22

3+
import Prelude
4+
35
import Language.PS.CST.Printers.PrintImports (printImports)
46
import Language.PS.CST.Printers.PrintModuleModuleNameAndExports (printModuleModuleNameAndExports)
57
import Language.PS.CST.Printers.TypeLevel (PrintType_Style(..), printConstraint, printDataCtor, printDataHead, printFixity, printFundep, printKind, printQualifiedName_AnyOpNameType, printQualifiedName_AnyProperNameType, printQualifiedName_Ident, printType, printTypeVarBinding)
6-
import Language.PS.CST.Printers.Utils (emptyColumn, emptyRow, ifelse, lines, maybeWrapInParentheses, printAndConditionallyAddNewlinesBetween, textFromNewtype, twoSpaceIdentation, wrapInParentheses)
8+
import Language.PS.CST.Printers.Utils (emptyColumn, emptyRow, ifelse, lines, maybeWrapInParentheses, printAndConditionallyAddNewlinesBetween, twoSpaceIdentation, wrapInParentheses)
79
import Language.PS.CST.Types (Binder(..), Comments(..), DeclDeriveType(..), Declaration(..), Expr(..), FixityOp(..), Foreign(..), Guarded(..), Instance, InstanceBinding(..), LetBinding(..), Module(..), RecordLabeled(..), RecordUpdate(..), Type(..), ValueBindingFields)
8-
import Prelude (flip, map, show, (#), ($), (<#>), (<<<), (==))
10+
import Language.PS.CST.ReservedNames (appendUnderscoreIfReserved, quoteIfReserved)
911

12+
import Data.Newtype (unwrap)
1013
import Data.Either (Either(..))
1114
import Data.Foldable (any, null)
1215
import Data.FunctorWithIndex (mapWithIndex)
@@ -92,22 +95,22 @@ printDeclaration (DeclNewtype { comments, head, name, type_ }) =
9295
printedType :: Box
9396
printedType = maybeWrapInParentheses (doWrap type_) $ printType PrintType_Multiline $ type_
9497
in
95-
printMaybeComments comments // (printDataHead (text "newtype") head <<+>> text "=" <<+>> (textFromNewtype name <<+>> printedType))
98+
printMaybeComments comments // (printDataHead (text "newtype") head <<+>> text "=" <<+>> ((text <<< appendUnderscoreIfReserved <<< unwrap) name <<+>> printedType))
9699
printDeclaration (DeclFixity { comments, fixityFields: { keyword, precedence, operator } }) =
97100
let
98101
printFixityOp :: FixityOp -> Box
99-
printFixityOp (FixityValue (Left qualifiedIdent) opName) = printQualifiedName_Ident qualifiedIdent <<+>> text "as" <<+>> textFromNewtype opName
100-
printFixityOp (FixityValue (Right qualifiedPropName) opName) = printQualifiedName_AnyProperNameType qualifiedPropName <<+>> text "as" <<+>> textFromNewtype opName
101-
printFixityOp (FixityType qualifiedPropName opName) = text "type" <<+>> printQualifiedName_AnyProperNameType qualifiedPropName <<+>> text "as" <<+>> textFromNewtype opName
102+
printFixityOp (FixityValue (Left qualifiedIdent) opName) = printQualifiedName_Ident qualifiedIdent <<+>> text "as" <<+>> (text <<< appendUnderscoreIfReserved <<< unwrap) opName
103+
printFixityOp (FixityValue (Right qualifiedPropName) opName) = printQualifiedName_AnyProperNameType qualifiedPropName <<+>> text "as" <<+>> (text <<< appendUnderscoreIfReserved <<< unwrap) opName
104+
printFixityOp (FixityType qualifiedPropName opName) = text "type" <<+>> printQualifiedName_AnyProperNameType qualifiedPropName <<+>> text "as" <<+>> (text <<< appendUnderscoreIfReserved <<< unwrap) opName
102105
in
103106
printMaybeComments comments // (printFixity keyword <<+>> text (show precedence) <<+>> printFixityOp operator)
104107
printDeclaration (DeclForeign { comments, foreign_ }) =
105108
printMaybeComments comments //
106109
( text "foreign" <<+>> text "import" <<+>>
107110
case foreign_ of
108-
(ForeignValue { ident, type_ }) -> textFromNewtype ident <<+>> text "::" <<+>> printType PrintType_Multiline type_
109-
(ForeignData { name, kind_ }) -> text "data" <<+>> textFromNewtype name <<+>> text "::" <<+>> printKind kind_
110-
(ForeignKind { name }) -> text "kind" <<+>> textFromNewtype name
111+
(ForeignValue { ident, type_ }) -> (text <<< appendUnderscoreIfReserved <<< unwrap) ident <<+>> text "::" <<+>> printType PrintType_Multiline type_
112+
(ForeignData { name, kind_ }) -> text "data" <<+>> (text <<< appendUnderscoreIfReserved <<< unwrap) name <<+>> text "::" <<+>> printKind kind_
113+
(ForeignKind { name }) -> text "kind" <<+>> (text <<< appendUnderscoreIfReserved <<< unwrap) name
111114
)
112115
printDeclaration (DeclDerive { comments, deriveType, head: { instName, instConstraints, instClass, instTypes } }) =
113116
let
@@ -132,7 +135,7 @@ printDeclaration (DeclDerive { comments, deriveType, head: { instName, instConst
132135

133136
types' = punctuateH left (emptyColumn) $ map (\type_ -> maybeWrapInParentheses (doWrap type_) $ printType PrintType_OneLine type_) instTypes
134137
in
135-
printMaybeComments comments // (text "derive" <<>> deriveType' <<+>> text "instance" <<+>> textFromNewtype instName <<+>> text "::" <<>> constraints' <<+>> printQualifiedName_AnyProperNameType instClass <<+>> types')
138+
printMaybeComments comments // (text "derive" <<>> deriveType' <<+>> text "instance" <<+>> (text <<< appendUnderscoreIfReserved <<< unwrap) instName <<+>> text "::" <<>> constraints' <<+>> printQualifiedName_AnyProperNameType instClass <<+>> types')
136139
printDeclaration (DeclClass { comments, head: { name, vars, super, fundeps }, methods }) =
137140
let
138141
printedVars =
@@ -151,15 +154,15 @@ printDeclaration (DeclClass { comments, head: { name, vars, super, fundeps }, me
151154
then nullBox
152155
else emptyColumn <<>> text "|" <<+>> (fundeps # map printFundep # punctuateH left (text ", "))
153156

154-
printedHeader = text "class" <<+>> printedSuper <<>> textFromNewtype name <<>> printedVars <<>> printedFundeps
157+
printedHeader = text "class" <<+>> printedSuper <<>> (text <<< appendUnderscoreIfReserved <<< unwrap) name <<>> printedVars <<>> printedFundeps
155158
in
156159
if null methods
157160
then printMaybeComments comments // printedHeader
158161
else
159162
printMaybeComments comments //
160163
( printedHeader <<+>> (text "where")
161164
// (methods
162-
<#> (\({ ident, type_ }) -> textFromNewtype ident <<+>> text "::" <<+>> (printType PrintType_Multiline type_))
165+
<#> (\({ ident, type_ }) -> (text <<< appendUnderscoreIfReserved <<< unwrap) ident <<+>> text "::" <<+>> (printType PrintType_Multiline type_))
163166
<#> (twoSpaceIdentation <<>> _)
164167
# vcat left
165168
)
@@ -169,7 +172,7 @@ printDeclaration (DeclInstanceChain { comments, instances }) =
169172
printInstance :: Instance -> Box
170173
printInstance { head: { instName, instConstraints, instClass, instTypes }, body } =
171174
let
172-
head = text "instance" <<+>> textFromNewtype instName <<+>> text "::" <<+>> printQualifiedName_AnyProperNameType instClass
175+
head = text "instance" <<+>> (text <<< appendUnderscoreIfReserved <<< unwrap) instName <<+>> text "::" <<+>> printQualifiedName_AnyProperNameType instClass
173176

174177
doWrap :: Type -> Boolean
175178
doWrap (TypeApp _ _) = true
@@ -196,11 +199,11 @@ printDeclaration (DeclInstanceChain { comments, instances }) =
196199
// (firstRow <<+>> text "where")
197200
// (twoSpaceIdentation <<>> printedBody)
198201
in instances <#> printInstance # punctuateV left (nullBox /+/ text "else" /+/ nullBox)
199-
printDeclaration (DeclSignature { comments, ident, type_ }) = printMaybeComments comments // (textFromNewtype ident <<+>> text "::" <<+>> printType PrintType_Multiline type_)
202+
printDeclaration (DeclSignature { comments, ident, type_ }) = printMaybeComments comments // ((text <<< appendUnderscoreIfReserved <<< unwrap) ident <<+>> text "::" <<+>> printType PrintType_Multiline type_)
200203
printDeclaration (DeclValue { comments, valueBindingFields }) = printMaybeComments comments // (printValueBindingFields valueBindingFields)
201204

202205
printInstanceBinding :: InstanceBinding -> Box
203-
printInstanceBinding (InstanceBindingSignature { ident, type_ }) = textFromNewtype ident <<+>> text "::" <<+>> printType PrintType_Multiline type_
206+
printInstanceBinding (InstanceBindingSignature { ident, type_ }) = (text <<< appendUnderscoreIfReserved <<< unwrap) ident <<+>> text "::" <<+>> printType PrintType_Multiline type_
204207
printInstanceBinding (InstanceBindingName valueBindingFields) = printValueBindingFields valueBindingFields
205208

206209
printValueBindingFields :: ValueBindingFields -> Box
@@ -211,7 +214,7 @@ printValueBindingFields { name, binders, guarded } =
211214
then nullBox
212215
else (punctuateH left emptyColumn $ map printBinder binders) <<>> emptyColumn
213216

214-
printedHead = textFromNewtype name <<+>> printedBinders <<>> text "="
217+
printedHead = (text <<< appendUnderscoreIfReserved <<< unwrap) name <<+>> printedBinders <<>> text "="
215218
in printGuarded printedHead guarded
216219

217220
printGuarded :: Box -> Guarded -> Box
@@ -240,8 +243,8 @@ exprShouldBeOnNextLine _ = false
240243

241244
printBinder :: Binder -> Box
242245
printBinder BinderWildcard = text "_"
243-
printBinder (BinderVar ident) = textFromNewtype ident
244-
printBinder (BinderNamed { ident, binder }) = textFromNewtype ident <<>> text "@" <<>> (wrapInParentheses $ printBinder binder)
246+
printBinder (BinderVar ident) = (text <<< appendUnderscoreIfReserved <<< unwrap) ident
247+
printBinder (BinderNamed { ident, binder }) = (text <<< appendUnderscoreIfReserved <<< unwrap) ident <<>> text "@" <<>> (wrapInParentheses $ printBinder binder)
245248
printBinder (BinderConstructor { name, args: [] }) = printQualifiedName_AnyProperNameType name
246249
printBinder (BinderConstructor { name, args }) = printQualifiedName_AnyProperNameType name <<+>> (punctuateH left emptyColumn $ map printBinder args)
247250
printBinder (BinderBoolean boolean) = text $ show boolean
@@ -255,11 +258,11 @@ printBinder (BinderTyped binder type_) = printBinder binder <<+>> text "::" <<+>
255258
printBinder (BinderOp binderLeft operator binderRight) = printBinder binderLeft <<+>> printQualifiedName_AnyOpNameType operator <<+>> printBinder binderRight
256259

257260
printRecordLabeled :: ∀ a . (a -> Box) -> RecordLabeled a -> Box
258-
printRecordLabeled _ (RecordPun ident) = textFromNewtype ident
259-
printRecordLabeled print (RecordField label a) = textFromNewtype label <<>> text ":" <<>> print a
261+
printRecordLabeled _ (RecordPun ident) = (text <<< quoteIfReserved <<< unwrap) ident
262+
printRecordLabeled print (RecordField label a) = (text <<< quoteIfReserved <<< unwrap) label <<>> text ":" <<+>> print a
260263

261264
printExpr :: Expr -> Box
262-
printExpr (ExprHole hole) = text "?" <<>> textFromNewtype hole
265+
printExpr (ExprHole hole) = text "?" <<>> (text <<< appendUnderscoreIfReserved <<< unwrap) hole
263266
printExpr ExprSection = text "_"
264267
printExpr (ExprIdent qualifiedIdent) = printQualifiedName_Ident qualifiedIdent
265268
printExpr (ExprConstructor qualifiedPropName) = printQualifiedName_AnyProperNameType qualifiedPropName
@@ -269,13 +272,13 @@ printExpr (ExprString string) = text $ show string
269272
printExpr (ExprNumber (Left int)) = text $ show int
270273
printExpr (ExprNumber (Right num)) = text $ show num
271274
printExpr (ExprArray array) = text "[" <<>> (punctuateH left (text ", ") $ map printExpr array) <<>> text "]"
272-
printExpr (ExprRecord arrayRecordLabeled) = punctuateH left (text ", ") $ map (printRecordLabeled printExpr) arrayRecordLabeled
275+
printExpr (ExprRecord arrayRecordLabeled) = text "{" <<+>> (punctuateH left (text ", ") $ map (printRecordLabeled printExpr) arrayRecordLabeled) <<+>> text "}"
273276
printExpr (ExprTyped expr type_) = printExpr expr <<+>> text "::" <<+>> printType PrintType_OneLine type_
274277
printExpr (ExprInfix exprLeft operator exprRight) = printExpr exprLeft <<+>> printExpr operator <<+>> printExpr exprRight
275278
printExpr (ExprOp exprLeft operator exprRight) = printExpr exprLeft <<+>> printQualifiedName_AnyOpNameType operator <<+>> printExpr exprRight
276279
printExpr (ExprOpName opName) = printQualifiedName_AnyOpNameType opName
277280
printExpr (ExprNegate expr) = text "-" <<>> printExpr expr
278-
printExpr (ExprRecordAccessor { recExpr, recPath }) = printExpr recExpr <<>> text "." <<>> (punctuateH left (text ".") $ map textFromNewtype recPath)
281+
printExpr (ExprRecordAccessor { recExpr, recPath }) = printExpr recExpr <<>> text "." <<>> (punctuateH left (text ".") $ map (text <<< appendUnderscoreIfReserved <<< unwrap) recPath)
279282
printExpr (ExprRecordUpdate expr recordUpdates) = wrapInParentheses $ printExpr expr <<+>> printRecordUpdates recordUpdates
280283
printExpr (ExprApp exprLeft exprRight) =
281284
let
@@ -365,13 +368,13 @@ printExpr (ExprDo doStatements) = nullBox -- TODO
365368
printExpr (ExprAdo { statements, result }) = nullBox -- TODO
366369

367370
printLetBinding :: LetBinding -> Box
368-
printLetBinding (LetBindingSignature { ident, type_ }) = textFromNewtype ident <<+>> text "::" <<+>> printType PrintType_Multiline type_
371+
printLetBinding (LetBindingSignature { ident, type_ }) = (text <<< appendUnderscoreIfReserved <<< unwrap) ident <<+>> text "::" <<+>> printType PrintType_Multiline type_
369372
printLetBinding (LetBindingName valueBindingFields) = printValueBindingFields valueBindingFields
370373
printLetBinding (LetBindingPattern { binder, where_: { expr, whereBindings } }) = printBinder binder /+/ printExpr expr // text "where" // (vsep 1 left $ map printLetBinding whereBindings)
371374

372375
printRecordUpdates :: NonEmptyArray RecordUpdate -> Box
373376
printRecordUpdates recordUpdates = text "{" <<+>> (punctuateH left (text ",") $ map printRecordUpdate recordUpdates) <<+>> text "}"
374377

375378
printRecordUpdate :: RecordUpdate -> Box
376-
printRecordUpdate (RecordUpdateLeaf label expr) = textFromNewtype label <<+>> text "=" <<+>> printExpr expr
377-
printRecordUpdate (RecordUpdateBranch label recordUpdates) = textFromNewtype label <<+>> text "=" <<+>> printRecordUpdates recordUpdates
379+
printRecordUpdate (RecordUpdateLeaf label expr) = (text <<< appendUnderscoreIfReserved <<< unwrap) label <<+>> text "=" <<+>> printExpr expr
380+
printRecordUpdate (RecordUpdateBranch label recordUpdates) = (text <<< appendUnderscoreIfReserved <<< unwrap) label <<+>> text "=" <<+>> printRecordUpdates recordUpdates

‎src/Language/PS/CST/Printers/PrintImports.purs

+12-8
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,15 @@
11
module Language.PS.CST.Printers.PrintImports where
22

3-
import Prelude (map, ($), (-), (<#>), (<>))
3+
import Prelude
4+
5+
import Language.PS.CST.Printers.Utils (emptyColumn, emptyRow, printConstructors, printModuleName, twoSpaceIdentation, wrapInParentheses)
6+
import Language.PS.CST.ReservedNames (appendUnderscoreIfReserved)
47
import Language.PS.CST.Types (DataMembers(..), Import(..), ImportDecl(..))
5-
import Language.PS.CST.Printers.Utils (emptyColumn, emptyRow, printConstructors, printModuleName, textFromNewtype, twoSpaceIdentation, wrapInParentheses)
8+
69
import Text.PrettyPrint.Boxes (Box, left, nullBox, text, vcat, vsep, (//), (<<+>>), (<<>>))
710
import Data.Foldable (length, null)
811
import Data.Maybe (Maybe(..), fromMaybe, maybe)
12+
import Data.Newtype (unwrap)
913
import Data.Unfoldable (replicate)
1014

1115
printImports :: Array ImportDecl -> Box
@@ -28,12 +32,12 @@ printImport (ImportDecl { moduleName, names, qualification }) =
2832
else
2933
let
3034
printImportName :: Import -> Box
31-
printImportName (ImportValue ident) = textFromNewtype ident
32-
printImportName (ImportOp valueOpName) = wrapInParentheses $ textFromNewtype valueOpName
35+
printImportName (ImportValue ident) = (text <<< appendUnderscoreIfReserved <<< unwrap) ident
36+
printImportName (ImportOp valueOpName) = wrapInParentheses $ (text <<< appendUnderscoreIfReserved <<< unwrap) valueOpName
3337
printImportName (ImportType properNameTypeName maybeDataMembers) =
3438
let
3539
printedProperNameTypeName :: Box
36-
printedProperNameTypeName = textFromNewtype properNameTypeName
40+
printedProperNameTypeName = (text <<< appendUnderscoreIfReserved <<< unwrap) properNameTypeName
3741

3842
printedMaybeDataMembers :: Box
3943
printedMaybeDataMembers = case maybeDataMembers of
@@ -42,9 +46,9 @@ printImport (ImportDecl { moduleName, names, qualification }) =
4246
(Just (DataEnumerated constructors)) -> wrapInParentheses $ printConstructors constructors
4347
in
4448
printedProperNameTypeName <<>> printedMaybeDataMembers
45-
printImportName (ImportTypeOp opName) = text "type" <<+>> (wrapInParentheses $ textFromNewtype $ opName)
46-
printImportName (ImportClass properName) = text "class" <<+>> (textFromNewtype $ properName)
47-
printImportName (ImportKind properName) = text "kind" <<+>> (textFromNewtype $ properName)
49+
printImportName (ImportTypeOp opName) = text "type" <<+>> (wrapInParentheses $ (text <<< appendUnderscoreIfReserved <<< unwrap) $ opName)
50+
printImportName (ImportClass properName) = text "class" <<+>> ((text <<< appendUnderscoreIfReserved <<< unwrap) $ properName)
51+
printImportName (ImportKind properName) = text "kind" <<+>> ((text <<< appendUnderscoreIfReserved <<< unwrap) $ properName)
4852

4953
printedNamesColumn = vcat left $ map printImportName names
5054

0 commit comments

Comments
 (0)