diff options
Diffstat (limited to 'style-generator/src/Writer.elm')
| -rw-r--r-- | style-generator/src/Writer.elm | 640 |
1 files changed, 0 insertions, 640 deletions
diff --git a/style-generator/src/Writer.elm b/style-generator/src/Writer.elm deleted file mode 100644 index ad9f3fd..0000000 --- a/style-generator/src/Writer.elm +++ /dev/null @@ -1,640 +0,0 @@ -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 |