INCLUDE "UHA_Syntax.ag" imports{ import Helium.Utils.OneLiner import Data.Char import Helium.Syntax.UHA_Utils (showNameAsOperator) import Helium.StaticAnalysis.Miscellaneous.TypeConversion import Helium.Syntax.UHA_Syntax import Data.List import Helium.Utils.Utils (internalError, hole) } { encloseSep :: String -> String -> String -> [OneLineTree] -> OneLineTree encloseSep left _ right [] = OneLineNode [OneLineText left, OneLineText right] encloseSep left sep right (t:ts) = OneLineNode ([ OneLineText left] ++ (t : concatMap (\t' -> [OneLineText sep,t']) ts) ++ [OneLineText right] ) punctuate :: String -> [OneLineTree] -> OneLineTree punctuate _ [] = OneLineText "" punctuate _ [t] = t punctuate s (t:ts) = OneLineNode (t : concatMap (\t' -> [OneLineText s,t']) ts) parens :: OneLineTree -> OneLineTree parens tree = OneLineNode [ OneLineText "(", tree, OneLineText ")" ] sepBy :: OneLineTree -> [OneLineTree] -> [OneLineTree] sepBy separator list = intersperse separator (map (\x -> OneLineNode [x]) list) intErr :: String -> String -> a intErr node message = internalError "UHA_OneLine" node message oneLineTreeAsOperator :: OneLineTree -> OneLineTree oneLineTreeAsOperator tree = case tree of OneLineNode [OneLineText (first:_)] | isAlpha first || first == '_' -> OneLineNode [ OneLineText "`", tree, OneLineText "`" ] _ -> tree } ATTR Declaration Expression Statement Qualifier Alternative FunctionBinding LeftHandSide Pattern Literal Name [ | | oneLineTree : OneLineTree ] ATTR GuardedExpression RightHandSide [ | | oneLineTree : { String -> OneLineTree } ] ATTR GuardedExpressions [ | | oneLineTree USE { : } { [] } : { [ String -> OneLineTree ] } ] ATTR Declarations Expressions Statements Qualifiers Alternatives FunctionBindings Patterns Names Strings [ | | oneLineTree USE { : } { [] } : { [ OneLineTree] } ] ATTR MaybeExpression [ | | oneLineTree : { Maybe OneLineTree } ] ATTR MaybeDeclarations [ | | oneLineTree : { Maybe [OneLineTree] } ] ATTR Name [ | | isOperator, isIdentifier, isSpecial USE { (error "Name has no children!") } { False } : Bool ] ATTR Names [ | | isOperator, isIdentifier, isSpecial USE { : } { [] } : { [Bool] } ] -- ------------------------------------------------------------------------ -- -- Declarations -- -- ------------------------------------------------------------------------ SEM MaybeDeclarations | Nothing loc.oneLineTree = Nothing | Just loc.oneLineTree = Just @declarations.oneLineTree -- declarations : Declarations SEM Declaration {- *** -} | Hole loc.oneLineTree = OneLineText hole -- range : Range -- id : Integer | Type loc.oneLineTree = intErr "Declaration" "type" -- range : Range -- simpletype : SimpleType -- type : Type | Data loc.oneLineTree = intErr "Declaration" "data" -- range : Range {- *** -} -- context : ContextItems -- simpletype : SimpleType -- constructors : Constructors -- derivings : Names | Newtype loc.oneLineTree = intErr "Declaration" "newtype" -- range : Range -- context : ContextItems -- simpletype : SimpleType -- constructor : Constructor -- has only one field, no strictness -- derivings : Names | Class loc.oneLineTree = intErr "Declaration" "class" -- range : Range -- context : ContextItems -- is a "simple" context -- simpletype : SimpleType -- Haskell 98 allows only one variable -- where : MaybeDeclarations -- cannot have everything | Instance loc.oneLineTree = intErr "Declaration" "instance" -- 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.oneLineTree = intErr "Declaration" "default" -- range : Range -- types : Types -- should be instances of Num | FunctionBindings loc.oneLineTree = punctuate ";" @bindings.oneLineTree -- range : Range {- *** -} -- bindings : FunctionBindings -- should all be for the same function | PatternBinding loc.oneLineTree = OneLineNode [ OneLineNode [@pattern.oneLineTree] , OneLineNode [@righthandside.oneLineTree " = "] ] -- range : Range -- pattern : Pattern -- righthandside : RightHandSide | TypeSignature loc.oneLineTree = OneLineNode [ OneLineText (concat . intersperse "," . map show $ @names.self) , OneLineText " :: " , OneLineText (show (makeTpSchemeFromType @type.self)) ] -- range : Range -- names : Names -- type : Type -- may have context | Fixity loc.oneLineTree = intErr "Declaration" "fixity" -- range : Range -- fixity : Fixity -- priority : MaybeInt -- operators : Names | Empty loc.oneLineTree = OneLineText "" -- range : Range -- ------------------------------------------------------------------------ -- -- Expressions -- -- ------------------------------------------------------------------------ SEM MaybeExpression | Nothing loc.oneLineTree = Nothing | Just loc.oneLineTree = Just @expression.oneLineTree -- expression : Expression SEM Expression {- *** -} | Literal loc.oneLineTree = OneLineNode [@literal.oneLineTree] -- range : Range -- literal : Literal | Variable loc.oneLineTree = OneLineNode [@name.oneLineTree] -- range : Range -- name : Name | Hole loc.oneLineTree = OneLineNode [OneLineText hole] -- range : Range -- id : Integer | Constructor loc.oneLineTree = OneLineNode [@name.oneLineTree] -- range : Range -- name : Name | Parenthesized loc.oneLineTree = parens @expression.oneLineTree -- range : Range -- expression : Expression | NormalApplication loc.oneLineTree = punctuate " " (@function.oneLineTree : @arguments.oneLineTree) -- range : Range -- function : Expression -- arguments : Expressions | InfixApplication loc.operatorName = oneLineTreeAsOperator @operator.oneLineTree loc.oneLineTree = case (@leftExpression.oneLineTree, @rightExpression.oneLineTree) of (Nothing, Nothing) -> parens @operatorName (Just l , Nothing) -> encloseSep "(" " " ")" [l, @operatorName] (Nothing, Just r ) -> encloseSep "(" " " ")" [@operatorName, r] (Just l , Just r ) -> OneLineNode [ l, OneLineText " ", @operatorName, OneLineText " ", r ] -- range : Range -- leftExpression : MaybeExpression -- operator : Expression -- rightExpression : MaybeExpression | If loc.oneLineTree = OneLineNode [ OneLineText "if " , OneLineNode [@guardExpression.oneLineTree] , OneLineText " then " , OneLineNode [@thenExpression.oneLineTree] , OneLineText " else " , OneLineNode [@elseExpression.oneLineTree] ] -- range : Range -- guardExpression : Expression -- thenExpression : Expression -- elseExpression : Expression | Lambda loc.oneLineTree = OneLineNode ( [ OneLineText "\\", punctuate " " @patterns.oneLineTree, OneLineText " -> " , OneLineNode [@expression.oneLineTree] ] ) -- range : Range -- patterns : Patterns -- expression : Expression | Case loc.oneLineTree = OneLineNode [ OneLineText "case " , OneLineNode [@expression.oneLineTree] , OneLineText " of " , encloseSep "{" "; " "}" @alternatives.oneLineTree ] -- range : Range -- expression : Expression -- alternatives : Alternatives | Let loc.oneLineTree = OneLineNode [ OneLineText "let " , encloseSep "{" "; " "}" @declarations.oneLineTree , OneLineText " in " , OneLineNode [@expression.oneLineTree] ] -- range : Range -- declarations : Declarations -- expression : Expression | Do loc.oneLineTree = OneLineNode [ OneLineText "do " , OneLineNode (sepBy (OneLineText "; ") @statements.oneLineTree) ] -- range : Range -- statements : Statements | List loc.oneLineTree = encloseSep "[" ", " "]" @expressions.oneLineTree -- range : Range -- expressions : Expressions | Tuple loc.oneLineTree = encloseSep "(" ", " ")" @expressions.oneLineTree -- range : Range -- expressions : Expressions | Comprehension loc.oneLineTree = OneLineNode [ OneLineText "[ " , OneLineNode [@expression.oneLineTree] , OneLineText " | " , OneLineNode [ punctuate ", " @qualifiers.oneLineTree ] , OneLineText " ]" ] -- range : Range -- expression : Expression -- qualifiers : Qualifiers | Typed loc.oneLineTree = OneLineNode [ OneLineNode [@expression.oneLineTree] , OneLineText " :: " , OneLineNode [ OneLineText (show (makeTpSchemeFromType @type.self))] ] -- range : Range -- expression : Expression -- type : Type | RecordConstruction loc.oneLineTree = intErr "Expression" "record construction" -- range : Range -- name : Name -- recordExpressionBindings : RecordExpressionBindings | RecordUpdate loc.oneLineTree = intErr "Expression" "record update" -- range : Range -- expression : Expression -- recordExpressionBindings : RecordExpressionBindings | Enum loc.oneLineTree = OneLineNode ( [ OneLineText "[" , OneLineNode [@from.oneLineTree] ] ++ maybe [] (\x -> [OneLineText ", ", x]) @then.oneLineTree ++ [ OneLineText " .. " ] ++ maybe [] (\x -> [OneLineNode [x]]) @to.oneLineTree ++ [ OneLineText "]" ] ) -- range : Range -- from : Expression -- then : MaybeExpression -- to : MaybeExpression | Negate loc.oneLineTree = OneLineNode [ OneLineText "-", OneLineNode [@expression.oneLineTree] ] | NegateFloat loc.oneLineTree = OneLineNode [ OneLineText "-.", OneLineNode [@expression.oneLineTree] ] -- range : Range -- expression : Expression SEM Statement | Expression loc.oneLineTree = @expression.oneLineTree -- range : Range -- expression : Expression | Let loc.oneLineTree = OneLineNode [ OneLineText "let ", encloseSep "{" "; " "}" @declarations.oneLineTree ] -- range : Range -- declarations : Declarations | Generator loc.oneLineTree = OneLineNode [ @pattern.oneLineTree, OneLineText " <- ", @expression.oneLineTree ] -- range : Range -- pattern : Pattern -- expression : Expression | Empty loc.oneLineTree = OneLineText "" -- range : Range SEM Qualifier | Guard loc.oneLineTree = @guard.oneLineTree -- range : Range -- guard : Expression -- type: Boolean | Let loc.oneLineTree = OneLineNode [ OneLineText "let ", encloseSep "{" "; " "}" @declarations.oneLineTree ] -- range : Range -- declarations : Declarations | Generator loc.oneLineTree = OneLineNode [ @pattern.oneLineTree, OneLineText " <- ", @expression.oneLineTree ] -- range : Range -- pattern : Pattern -- expression : Expression | Empty loc.oneLineTree = OneLineText "" -- range : Range SEM Alternative | Hole loc.oneLineTree = OneLineText hole | Alternative loc.oneLineTree = OneLineNode [ @pattern.oneLineTree, @righthandside.oneLineTree " -> " ] -- range : Range -- pattern : Pattern -- righthandside : RightHandSide | Empty loc.oneLineTree = OneLineText "" -- range : Range SEM GuardedExpression -- ToDo: or _Guard? | GuardedExpression loc.oneLineTree = \assign -> OneLineNode [ OneLineText " | ", @guard.oneLineTree, OneLineText assign, @expression.oneLineTree ] -- range : Range -- guard : Expression -- type: Boolean -- expression : Expression SEM FunctionBinding | Hole loc.oneLineTree = OneLineText hole | FunctionBinding loc.oneLineTree = OneLineNode [@lefthandside.oneLineTree, @righthandside.oneLineTree " = " ] -- range : Range -- lefthandside : LeftHandSide -- righthandside : RightHandSide SEM LeftHandSide | Function loc.oneLineTree = punctuate " " (@name.oneLineTree : @patterns.oneLineTree) -- range : Range -- name : Name -- patterns : Patterns | Infix loc.operatorName = oneLineTreeAsOperator @operator.oneLineTree loc.oneLineTree = punctuate " " [@leftPattern.oneLineTree, @operatorName, @rightPattern.oneLineTree] -- range : Range -- leftPattern : Pattern -- operator : Name -- rightPattern : Pattern | Parenthesized loc.oneLineTree = punctuate " " ( parens @lefthandside.oneLineTree : @patterns.oneLineTree ) -- range : Range -- lefthandside : LeftHandSide -- patterns : Patterns SEM RightHandSide | Expression loc.oneLineTree = \assign -> OneLineNode ( [ OneLineText assign, @expression.oneLineTree ] ++ case @where.oneLineTree of Nothing -> [] Just ds -> [ OneLineText " where ", encloseSep "{" "; " "}" ds ] ) -- range : Range -- expression : Expression -- where : MaybeDeclarations | Guarded loc.oneLineTree = \assign -> OneLineNode ( [ ge assign | ge <- @guardedexpressions.oneLineTree ] ++ case @where.oneLineTree of Nothing -> [] Just ds -> [ OneLineText " where ", encloseSep "{" "; " "}" ds ] ) -- range : Range -- guardedexpressions : GuardedExpressions -- where : MaybeDeclarations -- ------------------------------------------------------------------------ -- -- Patterns -- -- ------------------------------------------------------------------------ SEM Pattern | Hole loc.oneLineTree = OneLineText hole | Literal loc.oneLineTree = @literal.oneLineTree -- range : Range -- literal : Literal | Variable loc.oneLineTree = @name.oneLineTree -- range : Range -- name : Name | Constructor loc.operatorName = if @name.isOperator then OneLineNode [OneLineText "(", @name.oneLineTree, OneLineText ")"] else @name.oneLineTree loc.oneLineTree = OneLineNode (sepBy (OneLineText " ") (@operatorName : @patterns.oneLineTree)) -- range : Range -- name : Name -- patterns : Patterns | Parenthesized loc.oneLineTree = parens @pattern.oneLineTree -- range : Range -- pattern : Pattern | InfixConstructor loc.operatorName = OneLineText (showNameAsOperator @constructorOperator.self) loc.oneLineTree = OneLineNode [ OneLineNode [@leftPattern.oneLineTree] , OneLineText " " , OneLineNode [@operatorName] , OneLineText " " , OneLineNode [@rightPattern.oneLineTree] ] -- range : Range -- leftPattern : Pattern -- constructorOperator : Name -- rightPattern : Pattern | List loc.oneLineTree = encloseSep "[" ", " "]" @patterns.oneLineTree -- range : Range -- patterns : Patterns | Tuple loc.oneLineTree = encloseSep "(" ", " ")" @patterns.oneLineTree -- range : Range -- patterns : Patterns | Record loc.oneLineTree = intErr "pattern" "record" -- range : Range -- name : Name -- recordPatternBindings : RecordPatternBindings | Negate loc.oneLineTree = OneLineNode [ OneLineText "-", @literal.oneLineTree ] -- range : Range -- literal : Literal -- only numbers allowed here | NegateFloat loc.oneLineTree = OneLineNode [ OneLineText "-." , @literal.oneLineTree ] -- range : Range -- literal : Literal -- only numbers allowed here | As loc.oneLineTree = OneLineNode [ OneLineNode [@name.oneLineTree] , OneLineText "@" , OneLineNode [@pattern.oneLineTree] ] -- range : Range -- name : Name -- pattern : Pattern | Wildcard loc.oneLineTree = OneLineText "_" -- range : Range | Irrefutable loc.oneLineTree = intErr "pattern" "irrefutable" -- range : Range -- pattern : Pattern | Successor loc.oneLineTree = intErr "pattern" "successor" -- range : Range -- name : Name -- literal : Literal -- only integers allowed here -- ------------------------------------------------------------------------ -- -- Basics -- -- ------------------------------------------------------------------------ SEM Literal {- *** -} | Int loc.oneLineTree = OneLineText @value -- range : Range -- value : String | Char loc.oneLineTree = OneLineText ("'" ++ @value ++ "'") -- range : Range -- value : String -- without the quotes | Float loc.oneLineTree = OneLineText @value -- range : Range -- value : String | String loc.oneLineTree = OneLineText ("\"" ++ @value ++ "\"") -- range : Range -- value : String -- without the quotes SEM Name {- *** -} | Identifier lhs.isIdentifier = True loc.oneLineTree = OneLineText @name -- range : Range -- module : Strings -- name : String | Operator lhs.isOperator = True loc.oneLineTree = OneLineText @name -- range : Range -- module : Strings -- name : String | Special lhs.isSpecial = True loc.oneLineTree = OneLineText @name -- range : Range -- module : Strings -- name : String