helium-1.8: src/Helium/Syntax/UHA_Pretty.ag
INCLUDE "UHA_Syntax.ag"
imports{
-- Below two imports are to avoid clashes of "list" as used by the AG system.
-- Effectively, only list from the imported library needs to be qualified.
import Text.PrettyPrint.Leijen hiding (list)
import qualified Text.PrettyPrint.Leijen as PPrint
import Data.Char
import Top.Types (isTupleConstructor)
import Helium.Syntax.UHA_Syntax
import Helium.Utils.Utils (internalError, hole)
}
{
intErr :: String -> String -> a
intErr = internalError "UHA_Pretty"
opt :: Maybe Doc -> Doc
opt = maybe empty id
parensIf, backQuotesIf :: Bool -> Doc -> Doc
parensIf p n = if p then parens n else n
backQuotesIf p n = if p then text "`" <> n <> text "`" else n
parensIfList :: [Bool] -> [Doc] -> [Doc]
parensIfList ps ns = map (uncurry parensIf) (zip ps ns)
tupled1 :: [Doc] -> Doc
tupled1 [] = empty
tupled1 xs = tupled xs
tupled2 :: [Doc] -> Doc
tupled2 [] = empty
tupled2 xs = tupledUnit xs
tupledUnit :: [Doc] -> Doc
tupledUnit [x] = x
tupledUnit xs = tupled xs
commas :: [Doc] -> Doc
commas docs =
hcat (punctuate (comma <+> empty) docs)
utrechtList :: Doc -> Doc -> [Doc] -> Doc
utrechtList _ _ [] = empty
utrechtList start end (d:ds) =
let utrechtList' [] = end
utrechtList' (doc:docs) = comma <+> doc <$> utrechtList' docs
in
start <+> d <$> utrechtList' ds
}
ATTR
Module Export Body
ImportDeclaration ImportSpecification Import Declaration Fixity
Type SimpleType ContextItem
Constructor
FieldDeclaration
AnnotatedType
Expression
Statement
Qualifier
Alternative
RecordExpressionBinding RecordPatternBinding
FunctionBinding LeftHandSide
Pattern
Literal
Name
Range Position
[
|
| text : Doc
]
ATTR GuardedExpression RightHandSide
[
|
| text : { Doc -> Doc }
]
ATTR GuardedExpressions
[
|
| text USE { : } { [] } : { [ Doc -> Doc ] }
]
ATTR
Constructors Exports ImportDeclarations Imports Declarations Types ContextItems
FieldDeclarations AnnotatedTypes Expressions
Statements Qualifiers Alternatives RecordExpressionBindings RecordPatternBindings
FunctionBindings Patterns Names Strings
[
|
| text USE { : } { [] } : { [ Doc ] }
]
ATTR
MaybeExports MaybeDeclarations MaybeNames
[
|
| text : { Maybe [ Doc ] }
]
ATTR
MaybeExpression MaybeName MaybeInt MaybeImportSpecification
[
|
| text : { Maybe Doc }
]
ATTR
Name
[ | | isOperator, isIdentifier, isSpecial USE { (error "Name has no children!") } { False } : Bool ]
ATTR
Names
[ | | isOperator, isIdentifier, isSpecial USE { : } { [] } : { [Bool] } ]
-- ------------------------------------------------------------------------
-- -- Modules --
-- ------------------------------------------------------------------------
SEM Module
| Module loc.text =
maybe
id
( \name body ->
text "module" <+> name <+>
(maybe
(text "where")
(\x -> indent 4 (utrechtList (text "(") (text ")") x <+> text "where"))
@exports.text
)
<$> empty <$>
body
)
@name.text
@body.text
-- range : Range
-- name : MaybeName
-- exports : MaybeExports
-- body : Body
SEM MaybeExports
| Nothing loc.text = Nothing
| Just loc.text = Just @exports.text
-- exports : Exports
SEM Export
| Variable loc.text = @name.text
-- range : Range
-- name : Name
| TypeOrClass loc.text = @name.text <> maybe empty tupled (@names.text)
-- range : Range
-- name : Name
-- names : MaybeNames -- constructors or field names or class methods
| TypeOrClassComplete loc.text = @name.text
-- range : Range
-- name : Name
| Module loc.text = text "module" <+> @name.text
-- range : Range
-- name : Name -- this is a module name
SEM MaybeNames
| Nothing loc.text = Nothing
| Just loc.text = Just @names.text
-- names : Names
-- Since the parser cannot distinguish between types or constructors,
-- or between types and type classes, we do not have different cases (yet?).
SEM Body
| Hole loc.text = text hole
| Body loc.text = vcat
( @importdeclarations.text
++ {-intersperse empty-} @declarations.text
)
-- range : Range
-- importdeclarations : ImportDeclarations
-- declarations : Declarations
SEM ImportDeclaration
| Import loc.text = text "import" <+> (if @qualified then (text "qualified" <+>) else id) @name.text <+> maybe empty id @importspecification.text
-- range : Range
-- qualified : Bool
-- name : Name
-- asname : MaybeName
-- importspecification : MaybeImportSpecification
| Empty loc.text = empty
SEM MaybeImportSpecification
| Nothing loc.text = Nothing
| Just loc.text = Just @importspecification.text
-- importSpecification : ImportSpecification
SEM ImportSpecification
| Import loc.text = (if @hiding then (text "hiding" <+>) else id)
(tupled @imports.text)
-- range : Range
-- hiding : Bool
-- imports : Imports
SEM Import
| Variable loc.text = @name.text
-- range : Range
-- name : Name
| TypeOrClass loc.text = @name.text <> maybe empty tupled1 @names.text
-- range : Range
-- name : Name
-- names : Names -- constructors or field names or class methods
| TypeOrClassComplete loc.text = @name.text
-- range : Range
-- name : Name
-- cf. Export
-- ------------------------------------------------------------------------
-- -- Declarations --
-- ------------------------------------------------------------------------
SEM MaybeDeclarations
| Nothing loc.text = Nothing
-- | Just loc.text = Just @declarations.text
| Just loc.text = case filter ((/= "") . show) @declarations.text of
[] -> Nothing
xs -> Just xs
-- declarations : Declarations
SEM Declaration {- *** -}
| Hole loc.text = text hole
| Type loc.text = text "type" <+> @simpletype.text <+> text "=" <+> @type.text
-- range : Range
-- simpletype : SimpleType
-- type : Type
| Data loc.text =
text "data" <+>
@contextDoc
<>
@simpletype.text
<$>
(indent 4 $
vcat
( text "="
<+>
head @constructors.text
: map
(text "|" <+>)
(tail @constructors.text)
++ [@derivingDoc]
)
)
loc.contextDoc = case @context.text of
[] -> empty
[x] -> x <+> text "=>" <+> empty
xs -> tupled xs <+> text "=>" <+> empty
loc.derivingDoc =
if null @derivings.text then
empty
else
( empty
<+> text "deriving"
<+> tupledUnit @derivings.text
)
-- range : Range {- *** -}
-- context : ContextItems
-- simpletype : SimpleType
-- constructors : Constructors
-- derivings : Names
| Newtype loc.text = text "newtype"
<+>
@contextDoc
<>
@simpletype.text
<+>
@constructor.text
<>
@derivingDoc
loc.contextDoc = case @context.text of
[] -> empty
[x] -> x <+> text "=>" <+> empty
xs -> tupled xs <+> text "=>" <+> empty
loc.derivingDoc =
if null @derivings.text then
empty
else
( empty
<+> text "deriving"
<+> tupledUnit @derivings.text
)
-- range : Range
-- context : ContextItems
-- simpletype : SimpleType
-- constructor : Constructor -- has only one field, no strictness
-- derivings : Names
| Class loc.text = text "{- !!! class decl -}"
-- range : Range
-- context : ContextItems -- is a "simple" context
-- simpletype : SimpleType -- Haskell 98 allows only one variable
-- where : MaybeDeclarations -- cannot have everything
| Instance loc.text = text "{- !!! instance decl -}"
-- range : Range
-- context : ContextItems -- is a "simple" context
-- name : Name
-- types : Types -- Haskell 98 allows only one type
-- that is severely restricted
-- where : MaybeDeclarations -- cannot have everything
| Default loc.text = text "default" <+> tupled @types.text
-- range : Range
-- types : Types -- should be instances of Num
-- | FunctionBindings loc.text = foldl1 (<$>) @bindings.text
| FunctionBindings loc.text =
case filter ((/= "") . show) @bindings.text of -- AG: no eq for doc
[] -> text hole -- empty
xs -> foldl1 (<$>) xs
-- range : Range {- *** -}
-- bindings : FunctionBindings -- should all be for the same function
| PatternBinding loc.text = @pattern.text <+> @righthandside.text (text "=")
-- range : Range
-- pattern : Pattern
-- righthandside : RightHandSide
| TypeSignature loc.text = commas @namesDocs <+> text "::" <+> @type.text
loc.namesDocs = parensIfList @names.isOperator @names.text
-- range : Range
-- names : Names
-- type : Type -- may have context
| Fixity loc.text = @fixity.text <+> @ops
loc.ops = opt @priority.text <+>
commas
(map
(\(n, p) -> if p then
text "`" <> n <> text "`"
else
n
)
(zip @operators.text @operators.isIdentifier)
)
-- range : Range
-- fixity : Fixity
-- priority : MaybeInt
-- operators : Names
| Empty loc.text = empty
-- range : Range
SEM Fixity
| Infixl loc.text = text "infixl"
-- range : Range
| Infixr loc.text = text "infixr"
-- range : Range
| Infix loc.text = text "infix " -- space for alignment with infixl and infixr
-- range : Range
-- ------------------------------------------------------------------------
-- -- Types --
-- ------------------------------------------------------------------------
SEM Type {- *** -}
| Application loc.text = if @prefix then
foldl (<+>) @function.text @arguments.text
else if show @function.text == "[]" then
PPrint.list @arguments.text
else if isTupleConstructor (show @function.text) then
tupled @arguments.text
else
case @arguments.text of
[a, b] -> a <+> @function.text <+> b
_ -> text "{- error: Unknown special application notation -}"
-- range : Range
-- prefix : Bool
-- function : Type
-- arguments : Types
| Variable loc.text = @name.text {- *** -}
-- range : Range
-- name : Name
| Constructor loc.text = @name.text {- *** -}
-- range : Range
-- name : Name
| Qualified loc.text = case @context.text of
[ct] -> ct <+> text "=>" <+> @type.text
cts -> parens (commas cts) <+> text "=>" <+> @type.text
-- range : Range
-- context : ContextItems
-- type : Type
| Forall loc.text = foldl (<+>) (text "forall") @typevariables.text <> text "." <> @type.text
-- range : Range
-- typevariables : Names forall a b . Num a => a
-- type : Type
| Exists loc.text = foldl (<+>) (text "exists") @typevariables.text <> text "." <> @type.text
-- range : Range
-- typevariables : Names
-- type : Type
| Parenthesized loc.text = parens @type.text
-- range : Range
-- type : Type
SEM SimpleType
| SimpleType loc.text = foldl (<+>) @name.text @typevariables.text
-- name : Name
-- typevariables : Names
SEM ContextItem
| ContextItem loc.text = @name.text <+> head @types.text -- no parens because it is always a var
-- range : Range
-- name : Name -- that is the class
-- types : Types -- in Haskell 98, this is only one type
SEM Constructor
| Constructor loc.text = foldl (<+>) (parensIf @constructor.isOperator @constructor.text) @types.text
-- range : Range
-- constructor : Name
-- types : AnnotatedTypes
| Infix loc.text = @leftType.text <+> @constructorOperator.text <+> @rightType.text
-- range : Range
-- leftType : AnnotatedType
-- constructorOperator : Name
-- rightType : AnnotatedType
| Record loc.text = text "{- !!! record constructor -}"
-- range : Range
-- constructor : Name
-- fieldDeclarations : FieldDeclarations
SEM FieldDeclaration
| FieldDeclaration loc.text = text "{- !!! field declaration -}"
-- range : Range
-- names : Names
-- type : AnnotatedType
SEM AnnotatedType
| AnnotatedType loc.text = (if @strict then (text "!" <+>) else id) @type.text -- ToDo: or _Type?
-- range : Range
-- strict : Bool
-- type : Type
-- ------------------------------------------------------------------------
-- -- Expressions --
-- ------------------------------------------------------------------------
SEM MaybeExpression
| Nothing loc.text = Nothing
| Just loc.text = Just @expression.text
-- expression : Expression
SEM Expression {- *** -}
| Hole loc.text = text hole {- *** -}
-- range : Range
-- id : Integer
| Literal loc.text = @literal.text {- *** -}
-- range : Range
-- literal : Literal
| Variable loc.text = @name.text {- *** -}
-- range : Range
-- name : Name
| Constructor loc.text = @name.text {- *** -}
-- range : Range
-- name : Name
| Parenthesized loc.text = parens @expression.text
-- range : Range
-- expression : Expression
| NormalApplication loc.text = foldl (<+>) @function.text @arguments.text {- *** -}
-- range : Range
-- function : Expression
-- arguments : Expressions
| InfixApplication loc.text = let f [] m = m
f (c:cs) m = if isAlpha c && all (\ch -> ch == '_' || ch == '\'' || isAlphaNum ch) cs then char '`' <> m <> char '`' else m
in
case (@leftExpression.text, @rightExpression.text) of
(Nothing, Nothing) ->
parens @operator.text
(Just l , Nothing) ->
parens (l <+> @operator.text)
(Nothing, Just r ) ->
parens (@operator.text <+> r)
(Just l , Just r ) ->
l
<+>
f (show @operator.text) @operator.text
<+>
r
-- range : Range
-- leftExpression : MaybeExpression
-- operator : Expression
-- rightExpression : MaybeExpression
| If loc.text = text "if" <+> @guardExpression.text <$>
indent 4 (text "then" <+> @thenExpression.text <$>
text "else" <+> @elseExpression.text)
-- range : Range
-- guardExpression : Expression
-- thenExpression : Expression
-- elseExpression : Expression
| Lambda loc.text = text "\\" <+> foldl1 (<+>) @patterns.text <+> text "->" <+> @expression.text
-- range : Range
-- patterns : Patterns
-- expression : Expression
| Case loc.text = (text "case" <+> @expression.text <+> text "of" <$>
(indent 4 $ vcat @alternatives.text) <$> empty
)
-- range : Range
-- expression : Expression
-- alternatives : Alternatives
-- | Let loc.text = align (text "let"<+> align (vcat @declarations.text) <$>
-- text "in" <+> @expression.text) <$> empty
| Let loc.text = (text "let"<$>
(indent 4 $ vcat @declarations.text) <+>
text "in" <$>
(indent 4 $ @expression.text)
) <$> empty
-- range : Range
-- declarations : Declarations
-- expression : Expression
| Do loc.text = text "do" <$> (indent 4 $ vcat @statements.text) <$> empty
-- range : Range
-- statements : Statements
| List loc.text = PPrint.list @expressions.text
-- range : Range
-- expressions : Expressions
| Tuple loc.text = tupled @expressions.text
-- range : Range
-- expressions : Expressions
| Comprehension loc.text = text "[" <+> @expression.text <+>
text "|" <+> commas @qualifiers.text <+> text "]"
-- range : Range
-- expression : Expression
-- qualifiers : Qualifiers
| Typed loc.text = @expression.text <+> text "::" <+> @type.text {- ??? -}
-- range : Range
-- expression : Expression
-- type : Type
| RecordConstruction loc.text = intErr "Expression" "record construction"
-- range : Range
-- name : Name
-- recordExpressionBindings : RecordExpressionBindings
| RecordUpdate loc.text = intErr "Expression" "record update"
-- range : Range
-- expression : Expression
-- recordExpressionBindings : RecordExpressionBindings
| Enum loc.text =
text "[" <>
@from.text <>
maybe empty (text "," <+>) @then.text <+>
text ".." <+>
opt @to.text <>
text "]"
-- range : Range
-- from : Expression
-- then : MaybeExpression
-- to : MaybeExpression
| Negate loc.text = text "-" <> @expression.text
| NegateFloat loc.text = text "-." <> @expression.text
-- range : Range
-- expression : Expression
SEM Statement
| Expression loc.text = @expression.text
-- range : Range
-- expression : Expression
| Let loc.text = text "let" <$> (indent 4 $ vcat @declarations.text)
-- range : Range
-- declarations : Declarations
| Generator loc.text = @pattern.text <+> text "<-" <+> @expression.text
-- range : Range
-- pattern : Pattern
-- expression : Expression
| Empty loc.text = empty
-- range : Range
SEM Qualifier
| Guard loc.text = @guard.text
-- range : Range
-- guard : Expression -- type: Boolean
| Let loc.text = text "let" <$> (indent 4 $ vcat @declarations.text)
-- range : Range
-- declarations : Declarations
| Generator loc.text = @pattern.text <+> text "<-" <+> @expression.text
-- range : Range
-- pattern : Pattern
-- expression : Expression
| Empty loc.text = empty
-- range : Range
SEM Alternative
| Hole loc.text = text hole
| Alternative loc.text = @pattern.text <$> indent 2 (@righthandside.text (text "->"))
-- range : Range
-- pattern : Pattern
-- righthandside : RightHandSide
| Empty loc.text = empty
-- range : Range
SEM GuardedExpression -- ToDo: or _Guard?
| GuardedExpression loc.text = \assign -> text "|" <+> @guard.text <+> assign <+> @expression.text
-- range : Range
-- guard : Expression -- type: Boolean
-- expression : Expression
SEM RecordExpressionBinding
| RecordExpressionBinding loc.text = text "{- !!! record expression binding -}" -- ToDo: or _Binding?
-- range : Range
-- name : Name
-- expression : Expression
SEM RecordPatternBinding
| RecordPatternBinding loc.text = text "{- !!! record pattern binding -}" -- ToDo: or _Binding?
-- range : Range
-- name : Name
-- pattern : Pattern
SEM FunctionBinding
| Hole loc.text = empty --text ""
| FunctionBinding loc.text = @lefthandside.text <+> @righthandside.text (text "=")
-- range : Range
-- lefthandside : LeftHandSide
-- righthandside : RightHandSide
SEM LeftHandSide
| Function loc.text = foldl (<+>) (parensIf @name.isOperator @name.text) @patterns.text
-- range : Range
-- name : Name
-- patterns : Patterns
| Infix loc.text = @leftPattern.text <+> backQuotesIf (not @operator.isOperator) @operator.text <+> @rightPattern.text
-- range : Range
-- leftPattern : Pattern
-- operator : Name
-- rightPattern : Pattern
| Parenthesized loc.text = foldl (<+>) (parens @lefthandside.text) @patterns.text
-- range : Range
-- lefthandside : LeftHandSide
-- patterns : Patterns
SEM RightHandSide
| Expression
loc.text = \assign -> assign <$> @justText
loc.justText =
indent 4
( @expression.text
<> maybe
empty
(\ds -> PPrint.empty <$> text "where" <$> indent 4 (vcat ds))
@where.text
)
--
-- loc.text = \assign -> assign <+> @justText
-- loc.justText =
-- @expression.text
-- <> maybe
-- empty
-- (\ds -> PPrint.empty <$> indent 4 (text "where" <$> indent 4 (vcat ds)))
-- @where.text
-- range : Range
-- expression : Expression
-- where : MaybeDeclarations
| Guarded
loc.text =
\assign ->
( PPrint.empty
<$> vsep
(zipWith (\f x -> indent 4 (f x)) @guardedexpressions.text (repeat assign))
<> maybe
empty
(\ds -> PPrint.empty <$> indent 4 (text "where" <$> indent 4 (vcat ds)))
@where.text
)
-- range : Range
-- guardedexpressions : GuardedExpressions
-- where : MaybeDeclarations
-- ------------------------------------------------------------------------
-- -- Patterns --
-- ------------------------------------------------------------------------
SEM Pattern
| Hole loc.text = text hole
| Literal loc.text = @literal.text {- *** -}
-- range : Range
-- literal : Literal
| Variable loc.text = parensIf @name.isOperator @name.text {- *** -}
-- range : Range
-- name : Name
| Constructor loc.text = foldl (<+>) (parensIf @name.isOperator @name.text) @patterns.text {- *** -}
-- range : Range
-- name : Name
-- patterns : Patterns
| Parenthesized loc.text = parens @pattern.text
-- range : Range
-- pattern : Pattern
| InfixConstructor loc.text = @leftPattern.text <+> @constructorOperator.text <+> @rightPattern.text
-- range : Range
-- leftPattern : Pattern
-- constructorOperator : Name
-- rightPattern : Pattern
| List loc.text = PPrint.list @patterns.text
-- range : Range
-- patterns : Patterns
| Tuple loc.text = tupled @patterns.text
-- range : Range
-- patterns : Patterns
| Record loc.text = text "{- !!! record pattern -}"
-- range : Range
-- name : Name
-- recordPatternBindings : RecordPatternBindings
| Negate loc.text = text "-" <> @literal.text
-- range : Range
-- literal : Literal -- only numbers allowed here
| NegateFloat loc.text = text "-." <> @literal.text
-- range : Range
-- literal : Literal -- only numbers allowed here
| As loc.text = @name.text <> text "@" <> @pattern.text {- ??? -}
-- range : Range
-- name : Name
-- pattern : Pattern
| Wildcard loc.text = text "_"
-- range : Range
| Irrefutable loc.text = text "~" <> @pattern.text
-- range : Range
-- pattern : Pattern
| Successor loc.text = @name.text <+> text "+" <+> @literal.text -- n+k patterns
-- range : Range
-- name : Name
-- literal : Literal -- only integers allowed here
-- ------------------------------------------------------------------------
-- -- Basics --
-- ------------------------------------------------------------------------
SEM Literal {- *** -}
| Int loc.text = text @value {- *** -}
-- range : Range
-- value : String
| Char loc.text = text ("'" ++ @value ++ "'")
-- range : Range
-- value : String -- without the quotes
| Float loc.text = text @value
-- range : Range
-- value : String
| String loc.text = text ("\"" ++ @value ++ "\"")
-- range : Range
-- value : String -- without the quotes
SEM MaybeName
| Nothing loc.text = Nothing
| Just loc.text = Just @name.text
-- name : Name
SEM Name {- *** -}
| Identifier loc.text = text @name {- *** -}
lhs.isIdentifier = True
-- range : Range
-- module : Strings
-- name : String
| Operator loc.text = text @name
lhs.isOperator = True
-- range : Range
-- module : Strings
-- name : String
| Special loc.text = text @name
lhs.isSpecial = True
-- range : Range
-- module : Strings
-- name : String
SEM MaybeInt
| Nothing loc.text = Nothing
| Just loc.text = Just (int @int) -- int is a pprint util from PPrint.hs
-- int : Int
SEM Range
| Range loc.text = text "{-" <+> @start.text <+> text ", " <+> @stop.text <+> text "-}"
-- start : Position
-- stop : Position
SEM Position
| Position loc.text = text @filename <> tupled [int @line, int @column]
-- filename : String
-- line : Int
-- column : Int
| Unknown loc.text = text "Unknown"