From 075a1730211ed26e227bc8de6ad9a032048e66ee Mon Sep 17 00:00:00 2001
From: Jakub Hampl <kopomir@gmail.com>
Date: Tue, 11 Sep 2018 09:50:38 +0100
Subject: Add style generator

---
 style-generator/src/Writer.elm | 640 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 640 insertions(+)
 create mode 100644 style-generator/src/Writer.elm

(limited to 'style-generator/src/Writer.elm')

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
-- 
cgit v1.2.3