aboutsummaryrefslogtreecommitdiffstats
path: root/style-generator/src/Writer.elm
diff options
context:
space:
mode:
Diffstat (limited to 'style-generator/src/Writer.elm')
-rw-r--r--style-generator/src/Writer.elm640
1 files changed, 640 insertions, 0 deletions
diff --git a/style-generator/src/Writer.elm b/style-generator/src/Writer.elm
new file mode 100644
index 0000000..ad9f3fd
--- /dev/null
+++ b/style-generator/src/Writer.elm
@@ -0,0 +1,640 @@
+module Writer exposing (write, writeDeclaration, writeExpression, writeFile, writePattern, writeTypeAnnotation)
+
+{-| Copied and tweaked from Elm Syntax.
+
+
+# Elm.Writer
+
+Write a file to a string.
+@docs write, writeFile, writePattern, writeExpression, writeTypeAnnotation, writeDeclaration
+
+-}
+
+import Elm.Syntax.Declaration exposing (..)
+import Elm.Syntax.Documentation exposing (..)
+import Elm.Syntax.Exposing as Exposing exposing (..)
+import Elm.Syntax.Expression exposing (..)
+import Elm.Syntax.File exposing (..)
+import Elm.Syntax.Import exposing (Import)
+import Elm.Syntax.Infix exposing (..)
+import Elm.Syntax.Module exposing (..)
+import Elm.Syntax.ModuleName exposing (..)
+import Elm.Syntax.Node as Node exposing (Node(..))
+import Elm.Syntax.Pattern exposing (..)
+import Elm.Syntax.Range exposing (Range)
+import Elm.Syntax.Signature exposing (Signature)
+import Elm.Syntax.Type exposing (..)
+import Elm.Syntax.TypeAlias exposing (..)
+import Elm.Syntax.TypeAnnotation exposing (..)
+import List.Extra as List
+import StructuredWriter as Writer exposing (..)
+
+
+{-| Transform a writer to a string
+-}
+write : Writer -> String
+write =
+ Writer.write
+
+
+{-| Write a file
+-}
+writeFile : File -> Writer
+writeFile file =
+ breaked
+ [ writeModule <| Node.value file.moduleDefinition
+ , breaked (List.map (Node.value >> writeImport) file.imports)
+ , breaked (List.map writeDeclaration file.declarations)
+ ]
+
+
+writeModule : Module -> Writer
+writeModule m =
+ case m of
+ NormalModule defaultModuleData ->
+ writeDefaultModuleData defaultModuleData
+
+ PortModule defaultModuleData ->
+ spaced
+ [ string "port"
+ , writeDefaultModuleData defaultModuleData
+ ]
+
+ EffectModule effectModuleData ->
+ writeEffectModuleData effectModuleData
+
+
+writeDefaultModuleData : DefaultModuleData -> Writer
+writeDefaultModuleData { moduleName, exposingList } =
+ spaced
+ [ string "module"
+ , writeModuleName <| Node.value moduleName
+ , writeExposureExpose <| Node.value exposingList
+ ]
+
+
+writeEffectModuleData : EffectModuleData -> Writer
+writeEffectModuleData { moduleName, exposingList, command, subscription } =
+ spaced
+ [ string "effect"
+ , string "module"
+ , writeModuleName <| Node.value moduleName
+ , writeWhere ( command, subscription )
+ , writeExposureExpose <| Node.value exposingList
+ ]
+
+
+writeWhere : ( Maybe (Node String), Maybe (Node String) ) -> Writer
+writeWhere input =
+ case input of
+ ( Nothing, Nothing ) ->
+ epsilon
+
+ ( Just x, Nothing ) ->
+ spaced
+ [ string "where { command ="
+ , string <| Node.value x
+ , string "}"
+ ]
+
+ ( Nothing, Just x ) ->
+ spaced
+ [ string "where { subscription ="
+ , string <| Node.value x
+ , string "}"
+ ]
+
+ ( Just x, Just y ) ->
+ spaced
+ [ string "where { command ="
+ , string <| Node.value x
+ , string ", subscription ="
+ , string <| Node.value y
+ , string "}"
+ ]
+
+
+writeModuleName : ModuleName -> Writer
+writeModuleName moduleName =
+ string (String.join "." moduleName)
+
+
+writeExposureExpose : Exposing -> Writer
+writeExposureExpose x =
+ case x of
+ All _ ->
+ string "exposing (..)"
+
+ Explicit exposeList ->
+ let
+ diffLines =
+ List.map Node.range exposeList
+ |> startOnDifferentLines
+ in
+ spaced
+ [ string "exposing"
+ , parensComma diffLines (List.map writeExpose exposeList)
+ ]
+
+
+writeExpose : Node TopLevelExpose -> Writer
+writeExpose (Node _ exp) =
+ case exp of
+ InfixExpose x ->
+ string ("(" ++ x ++ ")")
+
+ FunctionExpose f ->
+ string f
+
+ TypeOrAliasExpose t ->
+ string t
+
+ TypeExpose { name, open } ->
+ case open of
+ Just _ ->
+ spaced
+ [ string name
+ , string "(..)"
+ ]
+
+ Nothing ->
+ string name
+
+
+startOnDifferentLines : List Range -> Bool
+startOnDifferentLines xs =
+ List.length (List.unique (List.map (.start >> .row) xs)) > 1
+
+
+writeImport : Import -> Writer
+writeImport { moduleName, moduleAlias, exposingList } =
+ spaced
+ [ string "import"
+ , writeModuleName <| Node.value moduleName
+ , maybe (Maybe.map (Node.value >> writeModuleName >> (\x -> spaced [ string "as", x ])) moduleAlias)
+ , maybe (Maybe.map writeExposureExpose exposingList)
+ ]
+
+
+writeLetDeclaration : Node LetDeclaration -> Writer
+writeLetDeclaration (Node _ letDeclaration) =
+ case letDeclaration of
+ LetFunction function ->
+ writeFunction function
+
+ LetDestructuring pattern expression ->
+ writeDestructuring pattern expression
+
+
+{-| Write a declaration
+-}
+writeDeclaration : Node Declaration -> Writer
+writeDeclaration (Node _ decl) =
+ case decl of
+ FunctionDeclaration function ->
+ writeFunction function
+
+ AliasDeclaration typeAlias ->
+ writeTypeAlias typeAlias
+
+ CustomTypeDeclaration type_ ->
+ writeType type_
+
+ PortDeclaration p ->
+ writePortDeclaration p
+
+ InfixDeclaration i ->
+ writeInfix i
+
+ Destructuring pattern expression ->
+ writeDestructuring pattern expression
+
+
+writeFunction : Function -> Writer
+writeFunction { documentation, signature, declaration } =
+ breaked
+ [ maybe (Maybe.map writeDocumentation documentation)
+ , maybe (Maybe.map (Node.value >> writeSignature) signature)
+ , writeFunctionImplementation <| Node.value declaration
+ ]
+
+
+writeFunctionImplementation : FunctionImplementation -> Writer
+writeFunctionImplementation declaration =
+ breaked
+ [ spaced
+ [ string <| Node.value declaration.name
+ , spaced (List.map writePattern declaration.arguments)
+ , string "="
+ ]
+ , indent 4 (writeExpression declaration.expression)
+ ]
+
+
+writeSignature : Signature -> Writer
+writeSignature signature =
+ spaced
+ [ string <| Node.value signature.name
+ , string ":"
+ , writeTypeAnnotation signature.typeAnnotation
+ ]
+
+
+writeDocumentation : Node Documentation -> Writer
+writeDocumentation =
+ Node.value >> string
+
+
+writeTypeAlias : TypeAlias -> Writer
+writeTypeAlias typeAlias =
+ breaked
+ [ spaced
+ [ string "type alias"
+ , string <| Node.value typeAlias.name
+ , spaced (List.map (Node.value >> string) typeAlias.generics)
+ , string "="
+ ]
+ , indent 4 (writeTypeAnnotation typeAlias.typeAnnotation)
+ ]
+
+
+writeType : Type -> Writer
+writeType type_ =
+ breaked
+ [ spaced
+ [ string "type"
+ , string <| Node.value type_.name
+ , spaced (List.map (Node.value >> string) type_.generics)
+ ]
+ , let
+ diffLines =
+ List.map Node.range type_.constructors
+ |> startOnDifferentLines
+ in
+ sepBy ( "=", "|", "" )
+ diffLines
+ (List.map (Node.value >> writeValueConstructor) type_.constructors)
+ ]
+
+
+writeValueConstructor : ValueConstructor -> Writer
+writeValueConstructor { name, arguments } =
+ spaced
+ [ string <| Node.value name
+ , spaced (List.map writeTypeAnnotation arguments)
+ ]
+
+
+writePortDeclaration : Signature -> Writer
+writePortDeclaration signature =
+ spaced [ string "port", writeSignature signature ]
+
+
+writeInfix : Infix -> Writer
+writeInfix { direction, precedence, operator, function } =
+ spaced
+ [ string "infix"
+ , case Node.value direction of
+ Left ->
+ string "left"
+
+ Right ->
+ string "right"
+
+ Non ->
+ string "non"
+ , string (String.fromInt (Node.value precedence))
+ , string (Node.value operator)
+ , string "="
+ , string (Node.value function)
+ ]
+
+
+writeDestructuring : Node Pattern -> Node Expression -> Writer
+writeDestructuring pattern expression =
+ breaked
+ [ spaced [ writePattern pattern, string "=" ]
+ , indent 4 (writeExpression expression)
+ ]
+
+
+{-| Write a type annotation
+-}
+writeTypeAnnotation : Node TypeAnnotation -> Writer
+writeTypeAnnotation (Node _ typeAnnotation) =
+ case typeAnnotation of
+ GenericType s ->
+ string s
+
+ Typed moduleNameAndName args ->
+ let
+ moduleName =
+ Node.value moduleNameAndName |> Tuple.first
+
+ k =
+ Node.value moduleNameAndName |> Tuple.second
+ in
+ spaced
+ ((string <| String.join "." (moduleName ++ [ k ]))
+ :: List.map (writeTypeAnnotation >> parensIfContainsSpaces) args
+ )
+
+ Unit ->
+ string "()"
+
+ Tupled xs ->
+ parensComma False (List.map writeTypeAnnotation xs)
+
+ Record xs ->
+ bracesComma False (List.map writeRecordField xs)
+
+ GenericRecord name fields ->
+ spaced
+ [ string "{"
+ , string <| Node.value name
+ , string "|"
+ , sepByComma False (List.map writeRecordField <| Node.value fields)
+ , string "}"
+ ]
+
+ FunctionTypeAnnotation left right ->
+ let
+ addParensForSubTypeAnnotation type_ =
+ case type_ of
+ Node _ (FunctionTypeAnnotation _ _) ->
+ join [ string "(", writeTypeAnnotation type_, string ")" ]
+
+ _ ->
+ writeTypeAnnotation type_
+ in
+ spaced
+ [ addParensForSubTypeAnnotation left
+ , string "->"
+ , addParensForSubTypeAnnotation right
+ ]
+
+
+writeRecordField : Node RecordField -> Writer
+writeRecordField (Node _ ( name, ref )) =
+ spaced
+ [ string <| Node.value name
+ , string ":"
+ , writeTypeAnnotation ref
+ ]
+
+
+{-| Writer an expression
+-}
+writeExpression : Node Expression -> Writer
+writeExpression (Node range inner) =
+ let
+ recurRangeHelper (Node x y) =
+ ( x, writeExpression (Node x y) )
+
+ writeRecordSetter : RecordSetter -> ( Range, Writer )
+ writeRecordSetter ( name, expr ) =
+ ( Node.range expr
+ , spaced [ string <| Node.value name, string "=", writeExpression expr ]
+ )
+
+ sepHelper : (Bool -> List Writer -> Writer) -> List ( Range, Writer ) -> Writer
+ sepHelper f l =
+ let
+ diffLines =
+ List.map Tuple.first l
+ |> startOnDifferentLines
+ in
+ f diffLines (List.map Tuple.second l)
+
+ fakeSepHelper : (Bool -> List Writer -> Writer) -> List ( Range, Writer ) -> Writer
+ fakeSepHelper f l =
+ f True (List.map Tuple.second l)
+ in
+ case inner of
+ UnitExpr ->
+ string "()"
+
+ Application xs ->
+ case xs of
+ [] ->
+ epsilon
+
+ [ x ] ->
+ writeExpression x
+
+ x :: rest ->
+ spaced
+ [ writeExpression x
+ , sepHelper sepBySpace (List.map recurRangeHelper rest)
+ ]
+
+ OperatorApplication x dir left right ->
+ case dir of
+ Left ->
+ sepHelper sepBySpace
+ [ ( Node.range left, writeExpression left )
+ , ( range, spaced [ string x, writeExpression right ] )
+ ]
+
+ Right ->
+ sepHelper sepBySpace
+ [ ( Node.range left, spaced [ writeExpression left, string x ] )
+ , ( Node.range right, writeExpression right )
+ ]
+
+ Non ->
+ sepHelper sepBySpace
+ [ ( Node.range left, spaced [ writeExpression left, string x ] )
+ , ( Node.range right, writeExpression right )
+ ]
+
+ FunctionOrValue moduleName name ->
+ case moduleName of
+ [] ->
+ string name
+
+ _ ->
+ join
+ [ writeModuleName <| moduleName
+ , string "."
+ , string <| name
+ ]
+
+ IfBlock condition thenCase elseCase ->
+ breaked
+ [ spaced [ string "if", writeExpression condition, string "then" ]
+ , indent 2 (writeExpression thenCase)
+ , string "else"
+ , indent 2 (writeExpression elseCase)
+ ]
+
+ PrefixOperator x ->
+ string ("(" ++ x ++ ")")
+
+ Operator x ->
+ string x
+
+ Hex h ->
+ string "TODO"
+
+ Integer i ->
+ string (String.fromInt i)
+
+ Floatable f ->
+ string (String.fromFloat f)
+
+ Negation x ->
+ append (string "-") (writeExpression x)
+
+ Literal s ->
+ string ("\"" ++ s ++ "\"")
+
+ CharLiteral c ->
+ string ("'" ++ String.fromList [ c ] ++ "'")
+
+ TupledExpression t ->
+ sepHelper sepByComma (List.map recurRangeHelper t)
+
+ ParenthesizedExpression x ->
+ join [ string "(", writeExpression x, string ")" ]
+
+ LetExpression letBlock ->
+ breaked
+ [ string "let"
+ , indent 2 (breaked (List.map writeLetDeclaration letBlock.declarations))
+ , string "in"
+ , indent 2 (writeExpression letBlock.expression)
+ ]
+
+ CaseExpression caseBlock ->
+ let
+ writeCaseBranch ( pattern, expression ) =
+ indent 2 <|
+ breaked
+ [ spaced [ writePattern pattern, string "->" ]
+ , indent 2 (writeExpression expression)
+ ]
+ in
+ breaked
+ [ spaced [ string "case", writeExpression caseBlock.expression, string "of" ]
+ , breaked (List.map writeCaseBranch caseBlock.cases)
+ ]
+
+ LambdaExpression lambda ->
+ spaced
+ [ join
+ [ string "\\"
+ , spaced (List.map writePattern lambda.args)
+ ]
+ , string "->"
+ , writeExpression lambda.expression
+ ]
+
+ RecordExpr setters ->
+ --sepHelper bracesComma (List.map (Node.value >> writeRecordSetter) setters)
+ bracesComma True (List.map (Node.value >> (\( name, expr ) -> spaced [ string <| Node.value name, string "=", writeExpression expr ])) setters)
+
+ ListExpr xs ->
+ fakeSepHelper bracketsComma (List.map recurRangeHelper xs)
+
+ RecordAccess expression accessor ->
+ join [ writeExpression expression, string ".", string <| Node.value accessor ]
+
+ RecordAccessFunction s ->
+ join [ string ".", string s ]
+
+ RecordUpdateExpression name updates ->
+ spaced
+ [ string "{"
+ , string <| Node.value name
+ , string "|"
+ , sepHelper sepByComma (List.map (Node.value >> writeRecordSetter) updates)
+ , string "}"
+ ]
+
+ GLSLExpression s ->
+ join
+ [ string "[glsl|"
+ , string s
+ , string "|]"
+ ]
+
+
+{-| Write a pattern
+-}
+writePattern : Node Pattern -> Writer
+writePattern (Node _ p) =
+ case p of
+ AllPattern ->
+ string "_"
+
+ UnitPattern ->
+ string "()"
+
+ CharPattern c ->
+ string ("'" ++ String.fromList [ c ] ++ "'")
+
+ StringPattern s ->
+ string s
+
+ HexPattern h ->
+ string "TODO"
+
+ IntPattern i ->
+ string (String.fromInt i)
+
+ FloatPattern f ->
+ string (String.fromFloat f)
+
+ TuplePattern inner ->
+ parensComma False (List.map writePattern inner)
+
+ RecordPattern inner ->
+ bracesComma False (List.map (Node.value >> string) inner)
+
+ UnConsPattern left right ->
+ spaced [ writePattern left, string "::", writePattern right ]
+
+ ListPattern inner ->
+ bracketsComma False (List.map writePattern inner)
+
+ VarPattern var ->
+ string var
+
+ NamedPattern qnr others ->
+ spaced
+ [ writeQualifiedNameRef qnr
+ , spaced (List.map writePattern others)
+ ]
+
+ AsPattern innerPattern asName ->
+ spaced [ writePattern innerPattern, string "as", string <| Node.value asName ]
+
+ ParenthesizedPattern innerPattern ->
+ spaced [ string "(", writePattern innerPattern, string ")" ]
+
+
+writeQualifiedNameRef : QualifiedNameRef -> Writer
+writeQualifiedNameRef { moduleName, name } =
+ case moduleName of
+ [] ->
+ string name
+
+ _ ->
+ join
+ [ writeModuleName moduleName
+ , string "."
+ , string name
+ ]
+
+
+
+-- Helpers
+
+
+parensIfContainsSpaces : Writer -> Writer
+parensIfContainsSpaces w =
+ if Writer.write w |> String.contains " " then
+ join [ string "(", w, string ")" ]
+ else
+ w
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-02 19:00:10 +0000