Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

appendUnderscoreIfReserved #8

Merged
merged 6 commits into from
Jul 22, 2020
Merged

appendUnderscoreIfReserved #8

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
4c329ff
feat: ExprRecord test
srghma Jul 14, 2020
e833482
feat: appendUnderscoreIfReserved
srghma Jul 15, 2020
a182965
feat: appendUnderscoreIfReserved -> use on all idents
srghma Jul 15, 2020
17ac750
refactor: remove textFromNewtype
srghma Jul 21, 2020
79b8ffe
feat: expr record -> print with quote instead of underscore
srghma Jul 21, 2020
09cc250
feat: type record -> print with quote instead of underscore
srghma Jul 21, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 3 additions & 2 deletions src/Language/PS/CST.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
module Language.PS.CST
( module Types
( module Export
) where

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
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
import Language.PS.CST.ReservedNames (reservedNames, appendUnderscoreIfReserved) as Export
55 changes: 29 additions & 26 deletions src/Language/PS/CST/Printers.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,12 +1,15 @@
module Language.PS.CST.Printers where

import Prelude

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

import Data.Newtype (unwrap)
import Data.Either (Either(..))
import Data.Foldable (any, null)
import Data.FunctorWithIndex (mapWithIndex)
Expand Down Expand Up @@ -92,22 +95,22 @@ printDeclaration (DeclNewtype { comments, head, name, type_ }) =
printedType :: Box
printedType = maybeWrapInParentheses (doWrap type_) $ printType PrintType_Multiline $ type_
in
printMaybeComments comments // (printDataHead (text "newtype") head <<+>> text "=" <<+>> (textFromNewtype name <<+>> printedType))
printMaybeComments comments // (printDataHead (text "newtype") head <<+>> text "=" <<+>> ((text <<< appendUnderscoreIfReserved <<< unwrap) name <<+>> printedType))
printDeclaration (DeclFixity { comments, fixityFields: { keyword, precedence, operator } }) =
let
printFixityOp :: FixityOp -> Box
printFixityOp (FixityValue (Left qualifiedIdent) opName) = printQualifiedName_Ident qualifiedIdent <<+>> text "as" <<+>> textFromNewtype opName
printFixityOp (FixityValue (Right qualifiedPropName) opName) = printQualifiedName_AnyProperNameType qualifiedPropName <<+>> text "as" <<+>> textFromNewtype opName
printFixityOp (FixityType qualifiedPropName opName) = text "type" <<+>> printQualifiedName_AnyProperNameType qualifiedPropName <<+>> text "as" <<+>> textFromNewtype opName
printFixityOp (FixityValue (Left qualifiedIdent) opName) = printQualifiedName_Ident qualifiedIdent <<+>> text "as" <<+>> (text <<< appendUnderscoreIfReserved <<< unwrap) opName
printFixityOp (FixityValue (Right qualifiedPropName) opName) = printQualifiedName_AnyProperNameType qualifiedPropName <<+>> text "as" <<+>> (text <<< appendUnderscoreIfReserved <<< unwrap) opName
printFixityOp (FixityType qualifiedPropName opName) = text "type" <<+>> printQualifiedName_AnyProperNameType qualifiedPropName <<+>> text "as" <<+>> (text <<< appendUnderscoreIfReserved <<< unwrap) opName
in
printMaybeComments comments // (printFixity keyword <<+>> text (show precedence) <<+>> printFixityOp operator)
printDeclaration (DeclForeign { comments, foreign_ }) =
printMaybeComments comments //
( text "foreign" <<+>> text "import" <<+>>
case foreign_ of
(ForeignValue { ident, type_ }) -> textFromNewtype ident <<+>> text "::" <<+>> printType PrintType_Multiline type_
(ForeignData { name, kind_ }) -> text "data" <<+>> textFromNewtype name <<+>> text "::" <<+>> printKind kind_
(ForeignKind { name }) -> text "kind" <<+>> textFromNewtype name
(ForeignValue { ident, type_ }) -> (text <<< appendUnderscoreIfReserved <<< unwrap) ident <<+>> text "::" <<+>> printType PrintType_Multiline type_
(ForeignData { name, kind_ }) -> text "data" <<+>> (text <<< appendUnderscoreIfReserved <<< unwrap) name <<+>> text "::" <<+>> printKind kind_
(ForeignKind { name }) -> text "kind" <<+>> (text <<< appendUnderscoreIfReserved <<< unwrap) name
)
printDeclaration (DeclDerive { comments, deriveType, head: { instName, instConstraints, instClass, instTypes } }) =
let
Expand All @@ -132,7 +135,7 @@ printDeclaration (DeclDerive { comments, deriveType, head: { instName, instConst

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

printedHeader = text "class" <<+>> printedSuper <<>> textFromNewtype name <<>> printedVars <<>> printedFundeps
printedHeader = text "class" <<+>> printedSuper <<>> (text <<< appendUnderscoreIfReserved <<< unwrap) name <<>> printedVars <<>> printedFundeps
in
if null methods
then printMaybeComments comments // printedHeader
else
printMaybeComments comments //
( printedHeader <<+>> (text "where")
// (methods
<#> (\({ ident, type_ }) -> textFromNewtype ident <<+>> text "::" <<+>> (printType PrintType_Multiline type_))
<#> (\({ ident, type_ }) -> (text <<< appendUnderscoreIfReserved <<< unwrap) ident <<+>> text "::" <<+>> (printType PrintType_Multiline type_))
<#> (twoSpaceIdentation <<>> _)
# vcat left
)
Expand All @@ -169,7 +172,7 @@ printDeclaration (DeclInstanceChain { comments, instances }) =
printInstance :: Instance -> Box
printInstance { head: { instName, instConstraints, instClass, instTypes }, body } =
let
head = text "instance" <<+>> textFromNewtype instName <<+>> text "::" <<+>> printQualifiedName_AnyProperNameType instClass
head = text "instance" <<+>> (text <<< appendUnderscoreIfReserved <<< unwrap) instName <<+>> text "::" <<+>> printQualifiedName_AnyProperNameType instClass

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

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

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

printedHead = textFromNewtype name <<+>> printedBinders <<>> text "="
printedHead = (text <<< appendUnderscoreIfReserved <<< unwrap) name <<+>> printedBinders <<>> text "="
in printGuarded printedHead guarded

printGuarded :: Box -> Guarded -> Box
Expand Down Expand Up @@ -240,8 +243,8 @@ exprShouldBeOnNextLine _ = false

printBinder :: Binder -> Box
printBinder BinderWildcard = text "_"
printBinder (BinderVar ident) = textFromNewtype ident
printBinder (BinderNamed { ident, binder }) = textFromNewtype ident <<>> text "@" <<>> (wrapInParentheses $ printBinder binder)
printBinder (BinderVar ident) = (text <<< appendUnderscoreIfReserved <<< unwrap) ident
printBinder (BinderNamed { ident, binder }) = (text <<< appendUnderscoreIfReserved <<< unwrap) ident <<>> text "@" <<>> (wrapInParentheses $ printBinder binder)
printBinder (BinderConstructor { name, args: [] }) = printQualifiedName_AnyProperNameType name
printBinder (BinderConstructor { name, args }) = printQualifiedName_AnyProperNameType name <<+>> (punctuateH left emptyColumn $ map printBinder args)
printBinder (BinderBoolean boolean) = text $ show boolean
Expand All @@ -255,11 +258,11 @@ printBinder (BinderTyped binder type_) = printBinder binder <<+>> text "::" <<+>
printBinder (BinderOp binderLeft operator binderRight) = printBinder binderLeft <<+>> printQualifiedName_AnyOpNameType operator <<+>> printBinder binderRight

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

printExpr :: Expr -> Box
printExpr (ExprHole hole) = text "?" <<>> textFromNewtype hole
printExpr (ExprHole hole) = text "?" <<>> (text <<< appendUnderscoreIfReserved <<< unwrap) hole
printExpr ExprSection = text "_"
printExpr (ExprIdent qualifiedIdent) = printQualifiedName_Ident qualifiedIdent
printExpr (ExprConstructor qualifiedPropName) = printQualifiedName_AnyProperNameType qualifiedPropName
Expand All @@ -269,13 +272,13 @@ printExpr (ExprString string) = text $ show string
printExpr (ExprNumber (Left int)) = text $ show int
printExpr (ExprNumber (Right num)) = text $ show num
printExpr (ExprArray array) = text "[" <<>> (punctuateH left (text ", ") $ map printExpr array) <<>> text "]"
printExpr (ExprRecord arrayRecordLabeled) = punctuateH left (text ", ") $ map (printRecordLabeled printExpr) arrayRecordLabeled
printExpr (ExprRecord arrayRecordLabeled) = text "{" <<+>> (punctuateH left (text ", ") $ map (printRecordLabeled printExpr) arrayRecordLabeled) <<+>> text "}"
printExpr (ExprTyped expr type_) = printExpr expr <<+>> text "::" <<+>> printType PrintType_OneLine type_
printExpr (ExprInfix exprLeft operator exprRight) = printExpr exprLeft <<+>> printExpr operator <<+>> printExpr exprRight
printExpr (ExprOp exprLeft operator exprRight) = printExpr exprLeft <<+>> printQualifiedName_AnyOpNameType operator <<+>> printExpr exprRight
printExpr (ExprOpName opName) = printQualifiedName_AnyOpNameType opName
printExpr (ExprNegate expr) = text "-" <<>> printExpr expr
printExpr (ExprRecordAccessor { recExpr, recPath }) = printExpr recExpr <<>> text "." <<>> (punctuateH left (text ".") $ map textFromNewtype recPath)
printExpr (ExprRecordAccessor { recExpr, recPath }) = printExpr recExpr <<>> text "." <<>> (punctuateH left (text ".") $ map (text <<< appendUnderscoreIfReserved <<< unwrap) recPath)
printExpr (ExprRecordUpdate expr recordUpdates) = wrapInParentheses $ printExpr expr <<+>> printRecordUpdates recordUpdates
printExpr (ExprApp exprLeft exprRight) =
let
Expand Down Expand Up @@ -365,13 +368,13 @@ printExpr (ExprDo doStatements) = nullBox -- TODO
printExpr (ExprAdo { statements, result }) = nullBox -- TODO

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

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

printRecordUpdate :: RecordUpdate -> Box
printRecordUpdate (RecordUpdateLeaf label expr) = textFromNewtype label <<+>> text "=" <<+>> printExpr expr
printRecordUpdate (RecordUpdateBranch label recordUpdates) = textFromNewtype label <<+>> text "=" <<+>> printRecordUpdates recordUpdates
printRecordUpdate (RecordUpdateLeaf label expr) = (text <<< appendUnderscoreIfReserved <<< unwrap) label <<+>> text "=" <<+>> printExpr expr
printRecordUpdate (RecordUpdateBranch label recordUpdates) = (text <<< appendUnderscoreIfReserved <<< unwrap) label <<+>> text "=" <<+>> printRecordUpdates recordUpdates
20 changes: 12 additions & 8 deletions src/Language/PS/CST/Printers/PrintImports.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,11 +1,15 @@
module Language.PS.CST.Printers.PrintImports where

import Prelude (map, ($), (-), (<#>), (<>))
import Prelude

import Language.PS.CST.Printers.Utils (emptyColumn, emptyRow, printConstructors, printModuleName, twoSpaceIdentation, wrapInParentheses)
import Language.PS.CST.ReservedNames (appendUnderscoreIfReserved)
import Language.PS.CST.Types (DataMembers(..), Import(..), ImportDecl(..))
import Language.PS.CST.Printers.Utils (emptyColumn, emptyRow, printConstructors, printModuleName, textFromNewtype, twoSpaceIdentation, wrapInParentheses)

import Text.PrettyPrint.Boxes (Box, left, nullBox, text, vcat, vsep, (//), (<<+>>), (<<>>))
import Data.Foldable (length, null)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Newtype (unwrap)
import Data.Unfoldable (replicate)

printImports :: Array ImportDecl -> Box
Expand All @@ -28,12 +32,12 @@ printImport (ImportDecl { moduleName, names, qualification }) =
else
let
printImportName :: Import -> Box
printImportName (ImportValue ident) = textFromNewtype ident
printImportName (ImportOp valueOpName) = wrapInParentheses $ textFromNewtype valueOpName
printImportName (ImportValue ident) = (text <<< appendUnderscoreIfReserved <<< unwrap) ident
printImportName (ImportOp valueOpName) = wrapInParentheses $ (text <<< appendUnderscoreIfReserved <<< unwrap) valueOpName
printImportName (ImportType properNameTypeName maybeDataMembers) =
let
printedProperNameTypeName :: Box
printedProperNameTypeName = textFromNewtype properNameTypeName
printedProperNameTypeName = (text <<< appendUnderscoreIfReserved <<< unwrap) properNameTypeName

printedMaybeDataMembers :: Box
printedMaybeDataMembers = case maybeDataMembers of
Expand All @@ -42,9 +46,9 @@ printImport (ImportDecl { moduleName, names, qualification }) =
(Just (DataEnumerated constructors)) -> wrapInParentheses $ printConstructors constructors
in
printedProperNameTypeName <<>> printedMaybeDataMembers
printImportName (ImportTypeOp opName) = text "type" <<+>> (wrapInParentheses $ textFromNewtype $ opName)
printImportName (ImportClass properName) = text "class" <<+>> (textFromNewtype $ properName)
printImportName (ImportKind properName) = text "kind" <<+>> (textFromNewtype $ properName)
printImportName (ImportTypeOp opName) = text "type" <<+>> (wrapInParentheses $ (text <<< appendUnderscoreIfReserved <<< unwrap) $ opName)
printImportName (ImportClass properName) = text "class" <<+>> ((text <<< appendUnderscoreIfReserved <<< unwrap) $ properName)
printImportName (ImportKind properName) = text "kind" <<+>> ((text <<< appendUnderscoreIfReserved <<< unwrap) $ properName)

printedNamesColumn = vcat left $ map printImportName names

Expand Down
Loading