diff --git a/assets/some-package/src/Main.elm b/assets/some-package/src/Main.elm index 69389b57f..a28870f7b 100644 --- a/assets/some-package/src/Main.elm +++ b/assets/some-package/src/Main.elm @@ -1,6 +1,6 @@ module Main exposing (add1) -{-| This library is a test library for testing the Elm compiler. +{-| This a test package for testing the Elm compiler. # Example diff --git a/src/Browser/Format.elm b/src/Browser/Format.elm index a8100c37a..1c9fe15ef 100644 --- a/src/Browser/Format.elm +++ b/src/Browser/Format.elm @@ -1,8 +1,9 @@ module Browser.Format exposing (run) -import Elm.Syntax.File -import ElmSyntaxParserLenient -import ElmSyntaxPrint +import Common.Format +import Compiler.Elm.Package as Pkg +import Compiler.Parse.Module as M +import Compiler.Parse.SyntaxVersion as SV @@ -11,20 +12,9 @@ import ElmSyntaxPrint run : String -> Result String String run inputText = - case ElmSyntaxParserLenient.run ElmSyntaxParserLenient.module_ inputText of - Just modu -> - Ok (render modu) - - Nothing -> - -- FIXME missings errs - Err "Something went wrong..." - - - --- RENDER - - -render : Elm.Syntax.File.File -> String -render modul = - ElmSyntaxPrint.module_ modul - |> ElmSyntaxPrint.toString + Common.Format.format SV.Guida (M.Package Pkg.core) inputText + |> Result.mapError + (\_ -> + -- FIXME missings errs + "Something went wrong..." + ) diff --git a/src/Common/Format.elm b/src/Common/Format.elm new file mode 100644 index 000000000..5be53872b --- /dev/null +++ b/src/Common/Format.elm @@ -0,0 +1,633 @@ +module Common.Format exposing (format) + +import Common.Format.Box as Box +import Common.Format.Render.Box as Render +import Compiler.AST.Source as Src +import Compiler.AST.Utils.Binop as Binop +import Compiler.AST.Utils.Shader as Shader +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Json.String as Json +import Compiler.Parse.Declaration as Decl +import Compiler.Parse.Module as M +import Compiler.Parse.Primitives as P +import Compiler.Parse.Space as Space +import Compiler.Parse.SyntaxVersion exposing (SyntaxVersion) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Syntax as E + + +format : SyntaxVersion -> M.ProjectType -> String -> Result E.Module String +format syntaxVersion projectType src = + P.fromByteString (M.chompModule syntaxVersion projectType) E.ModuleBadEnd src + |> Result.map render + + +render : M.Module -> String +render modu = + Box.render (Render.formatModule True 2 modu) ++ "\n" + + + +-- formatModule : M.Module -> String +-- formatModule modul = +-- formatInitialComments modul +-- ++ formatPreExposing modul +-- ++ formatExposing modul +-- ++ formatExports modul +-- ++ "\n" +-- ++ formatHeaderDocs modul +-- ++ formatHeaderComments modul +-- ++ "\n" +-- ++ formatImports modul +-- ++ formatInfixes modul +-- ++ "\n" +-- ++ formatDeclarations modul +-- ++ "\n" +-- formatInitialComments : M.Module -> String +-- formatInitialComments modul = +-- case modul.initialComments of +-- [] -> +-- "" +-- initialComments -> +-- String.join "\n" (List.map formatComment initialComments) +-- ++ "\n\n\n" +-- formatComment : Space.Comment -> String +-- formatComment comment = +-- case comment of +-- Space.LineComment str -> +-- "--" ++ String.trimRight str +-- Space.MultiComment str -> +-- "{-" ++ str ++ "-}" +-- hasLineComment : List Space.Comment -> Bool +-- hasLineComment = +-- List.any +-- (\comment -> +-- case comment of +-- Space.LineComment _ -> +-- True +-- Space.MultiComment _ -> +-- False +-- ) +-- formatPreExposing : M.Module -> String +-- formatPreExposing modul = +-- let +-- moduleWithEffects = +-- case Maybe.map .effects modul.header of +-- Just (M.Ports _) -> +-- "port module" +-- Just (M.Manager _ _) -> +-- "effect module" +-- _ -> +-- "module" +-- in +-- case Maybe.map .name modul.header of +-- Just ( beforeNameComments, A.At _ name, _ ) -> +-- if hasLineComment beforeNameComments then +-- moduleWithEffects +-- ++ "\n" +-- ++ indent +-- (String.join "\n" +-- (List.map formatComment beforeNameComments +-- ++ [ name ] +-- ) +-- ) +-- else +-- String.join " " +-- (moduleWithEffects +-- :: List.map formatComment beforeNameComments +-- ++ [ name ] +-- ) +-- Nothing -> +-- "module " ++ Name.mainModule +-- formatExposing : M.Module -> String +-- formatExposing modul = +-- case Maybe.map .name modul.header of +-- Just ( beforeNameComments, _, afterNameComments ) -> +-- if hasLineComment beforeNameComments then +-- indent (String.join "\n" (List.map formatComment beforeNameComments)) +-- else +-- String.join " " (List.map formatComment beforeNameComments) +-- Nothing -> +-- " exposing" +-- formatManager : Src.Manager -> String +-- formatManager manager = +-- case manager of +-- Src.Cmd (A.At _ cmdType) -> +-- "{ command = " ++ cmdType ++ " }" +-- Src.Sub (A.At _ subType) -> +-- "{ subscription = " ++ subType ++ " }" +-- Src.Fx (A.At _ cmdType) (A.At _ subType) -> +-- "{ command = " ++ cmdType ++ ", subscription = " ++ subType ++ " }" +-- formatExports : M.Module -> String +-- formatExports modul = +-- case Maybe.map .exports modul.header of +-- Just ( beforeExportsComments, A.At (A.Region (A.Position startRow _) (A.Position endRow _)) (Src.Explicit exposedList) ) -> +-- -- FIXME Src.YesDocs comment _ +-- -- let +-- -- _ = +-- -- Debug.log "parseOverview" (Docs.parseOverview comment) +-- -- in +-- let +-- exposed : List String +-- exposed = +-- exposedList +-- |> List.sortBy +-- (\exposedValue -> +-- case exposedValue of +-- Src.Operator _ name -> +-- ( 1, name ) +-- Src.Upper (A.At _ name) _ -> +-- ( 2, name ) +-- Src.Lower (A.At _ name) -> +-- ( 3, name ) +-- ) +-- |> List.map +-- (\exposedValue -> +-- case exposedValue of +-- Src.Operator _ name -> +-- "(" ++ name ++ ")" +-- Src.Upper (A.At _ name) (Src.Public _) -> +-- name ++ "(..)" +-- Src.Upper (A.At _ name) Src.Private -> +-- name +-- Src.Lower (A.At _ name) -> +-- name +-- ) +-- in +-- if endRow > startRow then +-- indent +-- ("\n" +-- ++ String.join "\n" +-- (List.map formatComment beforeExportsComments +-- ++ [ "( " ++ String.join "\n, " exposed ++ "\n)" ] +-- ) +-- ) +-- else +-- " " +-- ++ String.join " " +-- (List.map formatComment beforeExportsComments +-- ++ [ "(" ++ String.join ", " exposed ++ ")" ] +-- ) +-- Just ( beforeExportsComments, A.At _ Src.Open ) -> +-- " " +-- ++ String.join " " +-- (List.map formatComment beforeExportsComments +-- ++ [ "(..)" ] +-- ) +-- Nothing -> +-- " (..)" +-- formatHeaderDocs : M.Module -> String +-- formatHeaderDocs modul = +-- case Maybe.map .docs modul.header of +-- Just (Ok (Src.Comment comment)) -> +-- -- FIXME format comment +-- "\n{-|" ++ Json.fromComment comment ++ "-}\n" +-- _ -> +-- "" +-- formatHeaderComments : M.Module -> String +-- formatHeaderComments modul = +-- case Maybe.withDefault [] (Maybe.map .comments modul.header) of +-- [] -> +-- "" +-- comments -> +-- "\n" ++ String.join "\n" (List.map formatComment comments) ++ "\n" +-- formatImports : M.Module -> String +-- formatImports modul = +-- case modul.imports of +-- [] -> +-- "" +-- imports -> +-- String.join "\n" (List.map formatImport imports) ++ "\n\n" +-- formatImport : Src.Import -> String +-- formatImport ((Src.Import _ maybeAlias exposing_) as import_) = +-- let +-- formattedAlias : String +-- formattedAlias = +-- case maybeAlias of +-- Just alias_ -> +-- " as " ++ alias_ +-- Nothing -> +-- "" +-- formattedExposing : String +-- formattedExposing = +-- case exposing_ of +-- Src.Explicit [] -> +-- "" +-- Src.Explicit exposedList -> +-- let +-- exposed : List String +-- exposed = +-- exposedList +-- |> List.sortBy +-- (\exposedValue -> +-- case exposedValue of +-- Src.Operator _ name -> +-- ( 1, name ) +-- Src.Upper (A.At _ name) _ -> +-- ( 2, name ) +-- Src.Lower (A.At _ name) -> +-- ( 3, name ) +-- ) +-- |> List.map +-- (\exposedValue -> +-- case exposedValue of +-- Src.Operator _ name -> +-- "(" ++ name ++ ")" +-- Src.Upper (A.At _ name) (Src.Public _) -> +-- name ++ "(..)" +-- Src.Upper (A.At _ name) Src.Private -> +-- name +-- Src.Lower (A.At _ name) -> +-- name +-- ) +-- exposedRows : List Int +-- exposedRows = +-- List.map +-- (\exposedValue -> +-- case exposedValue of +-- Src.Operator (A.Region (A.Position startRow _) _) _ -> +-- startRow +-- Src.Upper (A.At (A.Region (A.Position startRow _) _) _) _ -> +-- startRow +-- Src.Lower (A.At (A.Region (A.Position startRow _) _) _) -> +-- startRow +-- ) +-- exposedList +-- multiLineExposing : Bool +-- multiLineExposing = +-- Maybe.map2 (<) (List.minimum exposedRows) (List.maximum exposedRows) +-- |> Maybe.withDefault False +-- in +-- if multiLineExposing then +-- indent +-- ("\nexposing\n" +-- ++ indent ("( " ++ String.join "\n, " exposed ++ "\n)") +-- ) +-- else +-- " exposing (" ++ String.join ", " exposed ++ ")" +-- Src.Open -> +-- " exposing (..)" +-- in +-- "import " +-- ++ Src.getImportName import_ +-- ++ formattedAlias +-- ++ formattedExposing +-- formatInfixes : M.Module -> String +-- formatInfixes modul = +-- case modul.infixes of +-- [] -> +-- "" +-- infixes -> +-- "\n" ++ String.join "\n" (List.map formatInfix infixes) ++ "\n\n" +-- formatInfix : A.Located Src.Infix -> String +-- formatInfix (A.At _ (Src.Infix op associativity precedence name)) = +-- let +-- associativityText : String +-- associativityText = +-- case associativity of +-- Binop.Left -> +-- "left" +-- Binop.Non -> +-- "non" +-- Binop.Right -> +-- "right" +-- in +-- "infix " ++ associativityText ++ " " ++ String.fromInt precedence ++ " (" ++ op ++ ") = " ++ name +-- formatDeclarations : M.Module -> String +-- formatDeclarations modul = +-- modul.decls +-- |> List.map formatDeclaration +-- |> String.join "\n\n\n" +-- formatDeclaration : Decl.Decl -> String +-- formatDeclaration decl = +-- case decl of +-- Decl.Value maybeDocs comments (A.At _ (Src.Value (A.At _ name) srcArgs body maybeType)) -> +-- let +-- extraComments = +-- case comments of +-- [] -> +-- "" +-- _ -> +-- "\n\n\n" ++ String.join "\n" (List.map formatComment comments) ++ "\n\n\n" +-- in +-- formatMaybeDocs maybeDocs +-- ++ extraComments +-- ++ formatMaybeType name maybeType +-- ++ String.join " " (name :: List.map (formatPattern True) srcArgs ++ [ "=" ]) +-- ++ "\n" +-- ++ indent (formatExpr False body) +-- Decl.Union maybeDocs (A.At _ (Src.Union (A.At _ name) args constructors)) -> +-- formatMaybeDocs maybeDocs +-- ++ "type " +-- ++ name +-- ++ String.concat (List.map (\(A.At _ arg) -> " " ++ arg) args) +-- ++ "\n" +-- ++ indent ("= " ++ String.join "\n| " (List.map (\( A.At _ cname, types ) -> String.join " " (cname :: List.map (typeParens forCtor << formatType) types)) constructors)) +-- Decl.Alias maybeDocs (A.At _ (Src.Alias (A.At _ name) args tipe)) -> +-- formatMaybeDocs maybeDocs +-- ++ "type alias " +-- ++ name +-- ++ String.concat (List.map (\(A.At _ arg) -> " " ++ arg) args) +-- ++ " =\n" +-- ++ indent (typeParens notRequired (formatType tipe)) +-- Decl.Port maybeDocs (Src.Port (A.At _ name) tipe) -> +-- formatMaybeDocs maybeDocs +-- ++ "port " +-- ++ name +-- ++ " : " +-- ++ typeParens notRequired (formatType tipe) +-- formatMaybeDocs : Maybe Src.Comment -> String +-- formatMaybeDocs maybeComment = +-- case maybeComment of +-- Just (Src.Comment comment) -> +-- -- FIXME format comment +-- "{-|" ++ Json.fromComment comment ++ "-}\n" +-- Nothing -> +-- "" +-- formatMaybeType : Name -> Maybe Src.Type -> String +-- formatMaybeType name maybeType = +-- case maybeType of +-- Just type_ -> +-- name ++ " : " ++ typeParens notRequired (formatType type_) ++ "\n" +-- Nothing -> +-- "" +-- -- TYPE +-- type alias TypeParensRequired = +-- Int +-- notRequired : TypeParensRequired +-- notRequired = +-- 0 +-- forLambda : TypeParensRequired +-- forLambda = +-- 1 +-- forCtor : TypeParensRequired +-- forCtor = +-- 2 +-- type TypeParensInner +-- = NotNeeded +-- | ForFunctionType +-- | ForTypeConstruction +-- typeParens : TypeParensRequired -> ( TypeParensInner, String ) -> String +-- typeParens outer ( inner, box ) = +-- if typeParensNeeded outer inner then +-- parens box +-- else +-- box +-- parens : String -> String +-- parens str = +-- "(" ++ str ++ ")" +-- typeParensNeeded : TypeParensRequired -> TypeParensInner -> Bool +-- typeParensNeeded outer inner = +-- case inner of +-- NotNeeded -> +-- False +-- ForTypeConstruction -> +-- outer >= forCtor +-- ForFunctionType -> +-- outer >= forLambda +-- formatType : Src.Type -> ( TypeParensInner, String ) +-- formatType (A.At (A.Region (A.Position startRow _) (A.Position endRow _)) type_) = +-- case type_ of +-- Src.TLambda arg result -> +-- ( ForFunctionType, typeParens forLambda (formatType arg) ++ " -> " ++ typeParens forLambda (formatType result) ) +-- Src.TVar name -> +-- ( NotNeeded, name ) +-- Src.TType _ name args -> +-- ( if List.isEmpty args then +-- NotNeeded +-- else +-- ForTypeConstruction +-- , String.join " " (name :: List.map (typeParens forCtor << formatType) args) +-- ) +-- Src.TTypeQual _ home name args -> +-- ( if List.isEmpty args then +-- NotNeeded +-- else +-- ForTypeConstruction +-- , String.join " " ((home ++ "." ++ name) :: List.map (typeParens forCtor << formatType) args) +-- ) +-- Src.TRecord [] Nothing -> +-- ( NotNeeded, "{}" ) +-- Src.TRecord fields (Just (A.At _ ext)) -> +-- ( NotNeeded +-- , "{ " +-- ++ ext +-- ++ " | " +-- ++ String.join ", " +-- (List.map +-- (\( A.At _ fieldName, fieldType ) -> +-- fieldName ++ " : " ++ typeParens notRequired (formatType fieldType) +-- ) +-- fields +-- ) +-- ++ " }" +-- ) +-- Src.TRecord fields Nothing -> +-- ( NotNeeded +-- , if endRow > startRow then +-- "{ " +-- ++ String.join "\n, " +-- (List.map +-- (\( A.At _ fieldName, fieldType ) -> +-- fieldName ++ " : " ++ typeParens notRequired (formatType fieldType) +-- ) +-- fields +-- ) +-- ++ "\n}" +-- else +-- "{ " +-- ++ String.join ", " +-- (List.map +-- (\( A.At _ fieldName, fieldType ) -> +-- fieldName ++ " : " ++ typeParens notRequired (formatType fieldType) +-- ) +-- fields +-- ) +-- ++ " }" +-- ) +-- Src.TUnit -> +-- ( NotNeeded, "()" ) +-- Src.TTuple a b cs -> +-- ( NotNeeded, "( " ++ String.join ", " (List.map (typeParens notRequired << formatType) (a :: b :: cs)) ++ " )" ) +-- formatPattern : Bool -> Src.Pattern -> String +-- formatPattern groupingRequired (A.At _ pattern) = +-- case pattern of +-- Src.PAnything name -> +-- "_" ++ name +-- Src.PVar name -> +-- name +-- Src.PRecord [] -> +-- "{}" +-- Src.PRecord fields -> +-- "{ " ++ String.join ", " (List.map (\(A.At _ name) -> name) fields) ++ " }" +-- Src.PAlias aliasPattern (A.At _ name) -> +-- withGrouping groupingRequired (formatPattern groupingRequired aliasPattern ++ " as " ++ name) +-- Src.PUnit -> +-- "()" +-- Src.PTuple a b cs -> +-- "( " ++ String.join ", " (List.map (formatPattern False) (a :: b :: cs)) ++ " )" +-- Src.PCtor _ name patterns -> +-- withGrouping (groupingRequired && not (List.isEmpty patterns)) +-- (String.join " " (name :: List.map (formatPattern False) patterns)) +-- Src.PCtorQual _ home name patterns -> +-- withGrouping (groupingRequired && not (List.isEmpty patterns)) +-- (String.join " " ((home ++ "." ++ name) :: List.map (formatPattern False) patterns)) +-- Src.PList [] -> +-- "[]" +-- Src.PList patterns -> +-- "[ " ++ String.join ", " (List.map (formatPattern False) patterns) ++ " ]" +-- Src.PCons hd tl -> +-- withGrouping groupingRequired (formatPattern False hd ++ " :: " ++ formatPattern groupingRequired tl) +-- Src.PChr chr -> +-- "'" ++ chr ++ "'" +-- Src.PStr str -> +-- "\"" ++ str ++ "\"" +-- Src.PInt int -> +-- String.fromInt int +-- formatExpr : Bool -> Src.Expr -> String +-- formatExpr groupingRequired (A.At (A.Region (A.Position startRow _) (A.Position endRow _)) expr) = +-- case expr of +-- Src.Chr chr -> +-- "'" ++ chr ++ "'" +-- Src.Str str -> +-- "\"" ++ str ++ "\"" +-- Src.Int int -> +-- String.fromInt int +-- Src.Float float -> +-- String.fromFloat float +-- Src.Var _ name -> +-- name +-- Src.VarQual _ prefix name -> +-- prefix ++ "." ++ name +-- Src.List [] -> +-- "[]" +-- Src.List list -> +-- if endRow > startRow then +-- "[ " ++ String.join "\n, " (List.map (formatExpr False) list) ++ "\n]" +-- else +-- "[ " ++ String.join ", " (List.map (formatExpr False) list) ++ " ]" +-- Src.Op op -> +-- "(" ++ op ++ ")" +-- Src.Negate subExpr -> +-- "-" ++ formatExpr False subExpr +-- Src.Binops ops final -> +-- if endRow > startRow then +-- String.join " " +-- (List.map +-- (\( opExpr, A.At _ op ) -> +-- formatExpr False opExpr ++ "\n" ++ indent op +-- ) +-- ops +-- ++ [ formatExpr False final ] +-- ) +-- else +-- String.join " " +-- (List.map +-- (\( opExpr, A.At _ op ) -> +-- formatExpr False opExpr ++ " " ++ op +-- ) +-- ops +-- ++ [ formatExpr False final ] +-- ) +-- Src.Lambda srcArgs body -> +-- withGrouping groupingRequired +-- ("\\" +-- ++ String.join " " (List.map (formatPattern False) srcArgs) +-- ++ " -> " +-- ++ formatExpr False body +-- ) +-- Src.Call func args -> +-- withGrouping groupingRequired +-- (List.map (formatExpr True) (func :: args) +-- |> String.join " " +-- ) +-- Src.If branches finally -> +-- String.join "\n\n" +-- (List.map +-- (\( condition, body ) -> +-- "if " +-- ++ formatExpr False condition +-- ++ " then\n" +-- ++ indent (formatExpr False body) +-- ) +-- branches +-- ++ [ "else\n" ++ indent (formatExpr False finally) ] +-- ) +-- Src.Let defs letExpr -> +-- "let\n" +-- ++ indent (String.join "\n\n" (List.map formatDef defs)) +-- ++ "\nin\n" +-- ++ formatExpr False letExpr +-- Src.Case caseExpr branches -> +-- "case " +-- ++ formatExpr False caseExpr +-- ++ " of\n" +-- ++ indent +-- (String.join "\n\n" +-- (List.map +-- (\( pattern, branchExpr ) -> +-- formatPattern False pattern +-- ++ " ->\n" +-- ++ indent (formatExpr False branchExpr) +-- ) +-- branches +-- ) +-- ) +-- Src.Accessor field -> +-- "." ++ field +-- Src.Access record (A.At _ field) -> +-- formatExpr False record ++ "." ++ field +-- Src.Update name fields -> +-- "{ " +-- ++ formatExpr False name +-- ++ " | " +-- ++ String.join ", " +-- (List.map (\( A.At _ fieldName, value ) -> fieldName ++ " = " ++ formatExpr False value) +-- fields +-- ) +-- ++ " }" +-- Src.Record [] -> +-- "{}" +-- Src.Record fields -> +-- "{ " +-- ++ String.join ", " +-- (List.map (\( A.At _ name, value ) -> name ++ " = " ++ formatExpr False value) +-- fields +-- ) +-- ++ " }" +-- Src.Unit -> +-- "()" +-- Src.Tuple a b cs -> +-- "( " ++ String.join ", " (List.map (formatExpr False) (a :: b :: cs)) ++ " )" +-- Src.Shader src _ -> +-- "[glsl|" ++ Shader.toJsStringBuilder src ++ "|]" +-- formatDef : A.Located Src.Def -> String +-- formatDef (A.At _ def) = +-- case def of +-- Src.Define (A.At _ name) srcArgs body maybeType -> +-- formatMaybeType name maybeType +-- ++ String.join " " (name :: List.map (formatPattern False) srcArgs ++ [ "=" ]) +-- ++ "\n" +-- ++ indent (formatExpr False body) +-- Src.Destruct pattern body -> +-- formatPattern False pattern +-- ++ " =\n" +-- ++ indent (formatExpr False body) +-- indent : String -> String +-- indent src = +-- src +-- |> String.split "\n" +-- |> List.map +-- (\line -> +-- if String.trim line == "" then +-- "" +-- else +-- String.repeat 4 " " ++ String.trimRight line +-- ) +-- |> String.join "\n" +-- withGrouping : Bool -> String -> String +-- withGrouping required str = +-- if required then +-- "(" ++ str ++ ")" +-- else +-- str diff --git a/src/Common/Format/Bimap.elm b/src/Common/Format/Bimap.elm new file mode 100644 index 000000000..78338a901 --- /dev/null +++ b/src/Common/Format/Bimap.elm @@ -0,0 +1,16 @@ +module Common.Format.Bimap exposing + ( Bimap + , fromList + ) + +import Data.Map as Map exposing (Dict) + + +type Bimap a b + = Bimap (Dict String a b) (Dict String b a) + + +fromList : (a -> String) -> (b -> String) -> List ( a, b ) -> Bimap a b +fromList toComparableA toComparableB list = + Bimap (Map.fromList toComparableA list) + (Map.fromList toComparableB (List.map (\( a, b ) -> ( b, a )) list)) diff --git a/src/Common/Format/Box.elm b/src/Common/Format/Box.elm new file mode 100644 index 000000000..0397f179a --- /dev/null +++ b/src/Common/Format/Box.elm @@ -0,0 +1,375 @@ +module Common.Format.Box exposing + ( Line, identifier, keyword, punc, literal, row, space + , blankLine, line, mustBreak, stack1, andThen + , isLine, allSingles, lineLength + , indent, prefix, addSuffix + , render + , Box(..), stack_ + ) + +{-| Ref.: `elm-format-lib/src/Box.hs` + +@docs Line, identifier, keyword, punc, literal, row, space +@docs Box(SingleLine, MustBreak), blankLine, line, mustBreak, stack', stack1, andThen +@docs isLine, allSingles, lineLength +@docs indent, prefix, addSuffix +@docs render + +-} + +import Basics.Extra exposing (flip) +import Prelude +import Result.Extra as Result +import Utils.Crash exposing (crash) +import Utils.Main as Utils + + +{-| A line is ALWAYS just one line. + +Space is self-explanatory, +Tab aligns to the nearest multiple of 4 spaces, +Text brings any string into the data structure, +Row joins more of these elements onto one line. + +-} +type Line + = Text String + | Row (List Line) + | Space + | Tab + + +identifier : String -> Line +identifier = + Text + + +keyword : String -> Line +keyword = + Text + + +punc : String -> Line +punc = + Text + + +literal : String -> Line +literal = + Text + + +{-| join more Line elements into one +-} +row : List Line -> Line +row = + Row + + +space : Line +space = + Space + + +{-| Box contains Lines (at least one - can't be empty). +Box either: + + - can appear in the middle of a line + (Stack someLine [], thus can be joined without problems), or + - has to appear on its own + (Stack someLine moreLines OR MustBreak someLine). + +MustBreak is only used for `--` comments. + +Stack contains two or more lines. + +Sometimes (see `prefix`) the first line of Stack +gets different treatment than the other lines. + +-} +type Box + = SingleLine Line + | Stack Line Line (List Line) + | MustBreak Line + + +blankLine : Box +blankLine = + line (literal "") + + +line : Line -> Box +line l = + SingleLine l + + +mustBreak : Line -> Box +mustBreak l = + MustBreak l + + +stack_ : Box -> Box -> Box +stack_ b1 b2 = + let + ( line1first, line1rest ) = + destructure b1 + + ( line2first, line2rest ) = + destructure b2 + in + case line1rest ++ line2first :: line2rest of + [] -> + crash "the list will contain at least line2first" + + first :: rest -> + Stack line1first first rest + + +andThen : List Box -> Box -> Box +andThen rest first = + List.foldl (flip stack_) first rest + + +stack1 : List Box -> Box +stack1 children = + case children of + [] -> + crash "stack1: empty structure" + + [ first ] -> + first + + boxes -> + Utils.foldr1 stack_ boxes + + +mapLines : (Line -> Line) -> Box -> Box +mapLines fn = + mapFirstLine fn fn + + +mapFirstLine : (Line -> Line) -> (Line -> Line) -> Box -> Box +mapFirstLine firstFn restFn b = + case b of + SingleLine l1 -> + SingleLine (firstFn l1) + + Stack l1 l2 ls -> + Stack (firstFn l1) (restFn l2) (List.map restFn ls) + + MustBreak l1 -> + MustBreak (firstFn l1) + + +indent : Box -> Box +indent = + mapLines (\l -> row [ Tab, l ]) + + +isLine : Box -> Result Box Line +isLine b = + case b of + SingleLine l -> + Ok l + + _ -> + Err b + + +destructure : Box -> ( Line, List Line ) +destructure b = + case b of + SingleLine l1 -> + ( l1, [] ) + + Stack l1 l2 rest -> + ( l1, l2 :: rest ) + + MustBreak l1 -> + ( l1, [] ) + + +allSingles : List Box -> Result (List Box) (List Line) +allSingles boxes = + case Result.combine (List.map isLine boxes) of + Ok lines_ -> + Ok lines_ + + _ -> + Err boxes + + +{-| Add the prefix to the first line, +pad the other lines with spaces of the same length + +EXAMPLE: +abcde +xyz +-----> +myPrefix abcde +xyz + +-} +prefix : Line -> Box -> Box +prefix pref = + let + prefixLength = + lineLength 0 pref + + paddingSpaces = + List.repeat prefixLength space + + padLineWithSpaces l = + row [ row paddingSpaces, l ] + + addPrefixToLine l = + row [ pref, l ] + in + mapFirstLine addPrefixToLine padLineWithSpaces + + +addSuffix : Line -> Box -> Box +addSuffix suffix b = + case destructure b of + ( l, [] ) -> + line (row [ l, suffix ]) + + ( l1, ls ) -> + line l1 + |> andThen (List.map line (Prelude.init ls)) + |> andThen [ line (row [ Prelude.last ls, suffix ]) ] + + +renderLine : Int -> Line -> String +renderLine startColumn line_ = + case line_ of + Text text -> + text + + Space -> + " " + + Tab -> + String.fromList (List.repeat (tabLength startColumn) ' ') + + Row lines_ -> + renderRow startColumn lines_ + + +render : Box -> String +render box = + case box of + SingleLine line_ -> + String.trimRight (renderLine 0 line_) ++ "\n" + + Stack l1 l2 rest -> + String.join "\n" (List.map (String.trimRight << renderLine 0) (l1 :: l2 :: rest)) + + MustBreak line_ -> + String.trimRight (renderLine 0 line_) ++ "\n" + + +lineLength : Int -> Line -> Int +lineLength startColumn line_ = + startColumn + + (case line_ of + Text string -> + String.length string + + Space -> + 1 + + Tab -> + tabLength startColumn + + Row lines_ -> + rowLength startColumn lines_ + ) + + +initRow : Int -> ( String, Int ) +initRow startColumn = + ( "", startColumn ) + + +spacesInTab : Int +spacesInTab = + 4 + + +spacesToNextTab : Int -> Int +spacesToNextTab startColumn = + modBy spacesInTab startColumn + + +tabLength : Int -> Int +tabLength startColumn = + spacesInTab - spacesToNextTab startColumn + + +{-| What happens here is we take a row and start building its contents +along with the resulting length of the string. We need to have that +because of Tabs, which need to be passed the current column in arguments +in order to determine how many Spaces are they going to span. +(See `tabLength`.) + +So for example if we have a Box [Space, Tab, Text "abc", Tab, Text "x"], +it goes like this: + +string | column | todo +"" | 0 | [Space, Tab, Text "abc", Tab, Text "x"] +" " | 1 | [Tab, Text "abc", Tab, Text "x"] +" " | 4 | [Text "abc", Tab, Text "x"] +" abc" | 7 | [Tab, Text "x"] +" abc " | 8 | [Text "x"] +" abc x" | 9 | [] + +Thus we get the result string with correctly rendered Tabs. + +The (String, Int) type here means the (string, column) from the table above. + +Then we just need to do one final modification to get from endColumn to resultLength, +which is what we are after in the function `rowLength`. + +-} +renderRow_ : Int -> List Line -> ( String, Int ) +renderRow_ startColumn lines_ = + let + ( result, endColumn ) = + List.foldl addLine (initRow startColumn) lines_ + + resultLength = + endColumn - startColumn + in + ( result, resultLength ) + + +{-| A step function for renderRow\_. + + addLine Tab ( " ", 1 ) == ( " ", 4 ) + +-} +addLine : Line -> ( String, Int ) -> ( String, Int ) +addLine line_ ( string, startColumn_ ) = + let + newString = + string ++ renderLine startColumn_ line_ + + newStartColumn = + lineLength startColumn_ line_ + in + ( newString, newStartColumn ) + + +{-| Extract the final string from renderRow\_ +-} +renderRow : Int -> List Line -> String +renderRow startColumn lines_ = + Tuple.first (renderRow_ startColumn lines_) + + +{-| Extract the final length from renderRow\_ +-} +rowLength : Int -> List Line -> Int +rowLength startColumn lines_ = + Tuple.second (renderRow_ startColumn lines_) diff --git a/src/Common/Format/ImportInfo.elm b/src/Common/Format/ImportInfo.elm new file mode 100644 index 000000000..3bdb26f16 --- /dev/null +++ b/src/Common/Format/ImportInfo.elm @@ -0,0 +1,192 @@ +module Common.Format.ImportInfo exposing (..) + +import Basics.Extra exposing (flip) +import Common.Format.Bimap as Bimap exposing (Bimap) +import Common.Format.KnownContents as KnownContents exposing (KnownContents) +import Compiler.AST.Source as Src +import Compiler.Elm.Compiler.Imports as Imports +import Compiler.Parse.Module as M +import Compiler.Reporting.Annotation as A +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet exposing (EverySet) + + +type ImportInfo + = ImportInfo + { exposed : Dict String String String + , aliases : Bimap String String + , directImports : EverySet String String + , ambiguous : Dict String String (List String) + , unresolvedExposingAll : EverySet String String -- any modules with exposing(..) and we didn't know the module contents + } + + +fromModule : KnownContents -> M.Module -> ImportInfo +fromModule knownContents modu = + fromImports knownContents (importsToDict modu.imports) + + +importsToDict : List Src.Import -> Dict String String Src.Import +importsToDict = + List.map (\((Src.Import (A.At _ name) _ _) as import_) -> ( name, import_ )) + >> Dict.fromList identity + + +fromImports : KnownContents -> Dict String String Src.Import -> ImportInfo +fromImports knownContents rawImports = + let + defaultImports : Dict String String Src.Import + defaultImports = + -- TODO check if we need to have only these 3: Basics, List, Maybe + -- [ ( [ "Basics" ], OpenListing (C ( [], [] ) ()) ) + -- , ( [ "List" ], ClosedListing ) + -- , ( [ "Maybe" ] + -- , ExplicitListing + -- (DetailedListing mempty mempty <| + -- Dict.fromList + -- [ ( UppercaseIdentifier "Maybe" + -- , C ( [], [] ) <| + -- C [] <| + -- ExplicitListing + -- (Dict.fromList + -- [ ( UppercaseIdentifier "Nothing", C ( [], [] ) () ) + -- , ( UppercaseIdentifier "Just", C ( [], [] ) () ) + -- ] + -- ) + -- False + -- ) + -- ] + -- ) + -- False + -- ) + -- ] + importsToDict Imports.defaults + + imports : Dict String String Src.Import + imports = + Dict.union rawImports defaultImports + + -- NOTE: this MUST prefer rawImports when there is a duplicate key + -- these are things we know will get exposed for certain modules when we see "exposing (..)" + -- only things that are currently useful for Elm 0.19 upgrade are included + moduleContents : String -> List String + moduleContents moduleName = + case moduleName of + "Basics" -> + [ "identity" + ] + + "Html.Attributes" -> + [ "style" + ] + + "List" -> + [ "filterMap" + ] + + "Maybe" -> + [ "Nothing" + , "Just" + ] + + _ -> + KnownContents.get moduleName knownContents + |> Maybe.withDefault [] + + getExposed : String -> Src.Import -> Dict String String String + getExposed moduleName (Src.Import _ _ exposing_) = + Dict.fromList identity <| + List.map (flip Tuple.pair moduleName) <| + case exposing_ of + Src.Open -> + moduleContents moduleName + + Src.Explicit _ -> + -- TODO + -- (fmap VarName <| Dict.keys <| AST.Module.values details) + -- <> (fmap TypeName <| Dict.keys <| AST.Module.types details) + -- <> (fmap CtorName <| foldMap (getCtorListings << extract << extract) <| Dict.elems <| AST.Module.types details) + [] + + -- getCtorListings : Listing (CommentedMap name ()) -> List name + -- getCtorListings listing = + -- case listing of + -- ClosedListing -> + -- [] + -- OpenListing _ -> + -- -- TODO: exposing (Type(..)) should pull in variant names from knownContents, though this should also be a warning because we can't know for sure which of those are for this type + -- [] + -- ExplicitListing ctors _ -> + -- Dict.keys ctors + exposed : Dict String String String + exposed = + -- TODO: mark ambiguous names if multiple modules expose them + Dict.foldl compare (\k v a -> Dict.union a <| getExposed k v) Dict.empty imports + + aliases : Bimap String String + aliases = + let + getAlias : Src.Import -> Maybe String + getAlias (Src.Import _ maybeAlias _) = + maybeAlias + + liftMaybe : ( a, Maybe b ) -> Maybe ( a, b ) + liftMaybe value = + case value of + ( _, Nothing ) -> + Nothing + + ( a, Just b ) -> + Just ( a, b ) + in + Dict.toList compare imports + |> List.map (Tuple.mapSecond getAlias) + |> List.filterMap liftMaybe + |> List.map (\( a, b ) -> ( b, a )) + |> Bimap.fromList identity identity + + noAlias : Src.Import -> Bool + noAlias (Src.Import _ maybeAlias _) = + case maybeAlias of + Just _ -> + False + + Nothing -> + True + + directs : EverySet String String + directs = + EverySet.union + (EverySet.singleton identity "Basics") + (Dict.filter (\_ -> noAlias) imports + |> Dict.keys compare + |> EverySet.fromList identity + ) + + ambiguous : Dict String String (List String) + ambiguous = + Dict.empty + + exposesAll : Src.Import -> Bool + exposesAll (Src.Import _ _ exposing_) = + case exposing_ of + Src.Open -> + True + + Src.Explicit _ -> + False + + unresolvedExposingAll : EverySet String String + unresolvedExposingAll = + Dict.filter (\_ -> exposesAll) rawImports + |> Dict.keys compare + |> EverySet.fromList identity + |> EverySet.filter (not << KnownContents.isKnown knownContents) + in + ImportInfo + { exposed = exposed + , aliases = aliases + , directImports = directs + , ambiguous = ambiguous + , unresolvedExposingAll = unresolvedExposingAll + } diff --git a/src/Common/Format/KnownContents.elm b/src/Common/Format/KnownContents.elm new file mode 100644 index 000000000..a2d397099 --- /dev/null +++ b/src/Common/Format/KnownContents.elm @@ -0,0 +1,38 @@ +module Common.Format.KnownContents exposing + ( KnownContents + , fromFunction + , get + , isKnown + , mempty + ) + +import Maybe.Extra as Maybe + + +type KnownContents + = KnownContents (String -> Maybe (List String)) -- return Nothing if the contents are unknown + + + +-- instance Semigroup KnownContents where +-- (KnownContents a) <> (KnownContents b) = KnownContents (\ns -> a ns <> b ns) + + +mempty : KnownContents +mempty = + fromFunction (always Nothing) + + +fromFunction : (String -> Maybe (List String)) -> KnownContents +fromFunction = + KnownContents + + +isKnown : KnownContents -> String -> Bool +isKnown (KnownContents lookup) = + Maybe.unwrap False (always True) << lookup + + +get : String -> KnownContents -> Maybe (List String) +get ns (KnownContents lookup) = + lookup ns diff --git a/src/Common/Format/Render/Box.elm b/src/Common/Format/Render/Box.elm new file mode 100644 index 000000000..ac251072a --- /dev/null +++ b/src/Common/Format/Render/Box.elm @@ -0,0 +1,2876 @@ +module Common.Format.Render.Box exposing (..) + +import Basics.Extra as Basics exposing (flip) +import Common.Format.Box as Box exposing (Box) +import Common.Format.ImportInfo as ImportInfo exposing (ImportInfo) +import Common.Format.KnownContents as KnownContents +import Common.Format.Render.ElmStructure as ElmStructure +import Common.Format.Render.Markdown as Markdown +import Compiler.AST.Source as Src +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Parse.Declaration as Decl +import Compiler.Parse.Module as M +import Compiler.Parse.Space as Space +import Compiler.Reporting.Annotation as A +import Data.Map as Map exposing (Dict) +import Data.Set as EverySet exposing (EverySet) +import Hex +import Language.GLSL.Syntax exposing (Statement(..)) +import Maybe.Extra as Maybe +import Utils.Crash exposing (crash) + + +pleaseReport__ : String -> String -> String +pleaseReport__ what details = + -- TODO: include version in the message + "" + + +pleaseReport_ : String -> String -> Box.Line +pleaseReport_ what details = + Box.keyword (pleaseReport__ what details) + + +pleaseReport : String -> String -> Box +pleaseReport what details = + Box.line (pleaseReport_ what details) + + +surround : Char -> Char -> Box -> Box +surround left right b = + let + left_ : Box.Line + left_ = + Box.punc (String.fromChar left) + + right_ : Box.Line + right_ = + Box.punc (String.fromChar right) + in + case b of + Box.SingleLine b_ -> + Box.line (Box.row [ left_, b_, right_ ]) + + _ -> + Box.stack1 + [ Box.prefix left_ b + , Box.line right_ + ] + + +parens : Box -> Box +parens = + surround '(' ')' + + +formatBinary : Bool -> Box -> List ( ( Bool, Comments, Box ), Box ) -> Box +formatBinary multiline left ops = + case ops of + [] -> + left + + ( ( isLeftPipe, comments, op ), next ) :: rest -> + if isLeftPipe then + ElmStructure.forceableSpaceSepOrIndented multiline + (ElmStructure.spaceSepOrStack left + (List.concat + [ Maybe.toList <| formatComments comments + , [ op ] + ] + ) + ) + [ formatBinary multiline next rest ] + + else + formatBinary + multiline + (ElmStructure.forceableSpaceSepOrIndented multiline left [ formatCommentedApostrophe comments (ElmStructure.spaceSepOrPrefix op next) ]) + rest + + +splitWhere : (a -> Bool) -> List a -> List (List a) +splitWhere predicate list = + let + merge : List a -> List (List a) -> List (List a) + merge acc result = + List.reverse acc :: result + + step : a -> ( List a, List (List a) ) -> ( List a, List (List a) ) + step next ( acc, result ) = + if predicate next then + ( [], merge (next :: acc) result ) + + else + ( next :: acc, result ) + in + list + |> List.foldl step ( [], [] ) + |> Basics.uncurry merge + |> List.reverse + |> List.filter List.isEmpty + + +type DeclarationType + = DComment + | DStarter + | DCloser + | DDefinition (Maybe (Ref ())) + | DFixity + | DDocComment + + +declarationType : TopLevelStructure BodyEntryType -> DeclarationType +declarationType decl = + case decl of + Entry entry -> + case entry of + BodyNamed name -> + DDefinition (Just name) + + BodyUnnamed -> + DDefinition Nothing + + BodyFixity -> + DFixity + + DocComment _ -> + DDocComment + + BodyComment Space.CommentTrickOpener -> + DStarter + + BodyComment Space.CommentTrickCloser -> + DCloser + + BodyComment _ -> + DComment + + +removeDuplicates : List (List ( Comments, Src.Exposed, Comments )) -> List (List ( Comments, Src.Exposed, Comments )) +removeDuplicates input = + let + step : + List ( Comments, Src.Exposed, Comments ) + -> ( List (List ( Comments, Src.Exposed, Comments )), EverySet String ( Comments, Src.Exposed, Comments ) ) + -> ( List (List ( Comments, Src.Exposed, Comments )), EverySet String ( Comments, Src.Exposed, Comments ) ) + step next ( acc, seen ) = + case List.foldl stepChildren ( [], seen ) next |> (\( a, b ) -> ( List.reverse a, b )) of + ( [], seen_ ) -> + ( acc, seen_ ) + + ( children_, seen_ ) -> + ( children_ :: acc, seen_ ) + + stepChildren : + ( Comments, Src.Exposed, Comments ) + -> ( List ( Comments, Src.Exposed, Comments ), EverySet String ( Comments, Src.Exposed, Comments ) ) + -> ( List ( Comments, Src.Exposed, Comments ), EverySet String ( Comments, Src.Exposed, Comments ) ) + stepChildren next ( acc, seen ) = + if EverySet.member (\( _, v, _ ) -> Debug.todo "v") next seen then + ( acc, seen ) + + else + ( next :: acc, EverySet.insert (\( _, v, _ ) -> Debug.todo "v") next seen ) + in + List.foldl step ( [], EverySet.empty ) input + |> Tuple.first + |> List.reverse + + +sortVars : Bool -> EverySet String ( Comments, Src.Exposed, Comments ) -> List (List String) -> ( List (List ( Comments, Src.Exposed, Comments )), Comments ) +sortVars forceMultiline fromExposing fromDocs = + let + varOrder : ( Comments, Src.Exposed, Comments ) -> ( Int, String ) + varOrder ( _, exposed, _ ) = + case exposed of + Src.Operator _ name -> + ( 1, name ) + + Src.Upper (A.At _ name) _ -> + ( 2, name ) + + Src.Lower (A.At _ name) -> + ( 3, name ) + + listedInDocs : List (List ( Comments, Src.Exposed, Comments )) + listedInDocs = + fromDocs + |> List.map (List.filterMap (\v -> Map.get identity v allowedInDocs)) + |> List.filter (not << List.isEmpty) + |> List.map (List.map (\v -> ( [], v, [] ))) + |> removeDuplicates + + listedInExposing = + fromExposing + |> EverySet.toList (\a b -> compare (varName a) (varName b)) + |> List.sortBy varOrder + + varName : ( Comments, Src.Exposed, Comments ) -> String + varName ( _, exposed, _ ) = + case exposed of + Src.Lower (A.At _ name) -> + name + + Src.Upper (A.At _ name) _ -> + name + + Src.Operator _ name -> + name + + varSetToMap : EverySet String ( Comments, Src.Exposed, Comments ) -> Dict String String Src.Exposed + varSetToMap set = + EverySet.toList (\a b -> compare (varName a) (varName b)) set + |> List.map (\(( _, exposed, _ ) as var) -> ( varName var, exposed )) + |> Map.fromList identity + + allowedInDocs : Dict String String Src.Exposed + allowedInDocs = + varSetToMap fromExposing + + allFromDocs : EverySet String String + allFromDocs = + EverySet.fromList identity (List.map varName (List.concat listedInDocs)) + + inDocs : ( List Space.Comment, Src.Exposed, List Space.Comment ) -> Bool + inDocs x = + EverySet.member identity (varName x) allFromDocs + + remainingFromExposing : List ( List Space.Comment, Src.Exposed, List Space.Comment ) + remainingFromExposing = + listedInExposing + |> List.filter (not << inDocs) + + commentsFromReorderedVars : List Space.Comment + commentsFromReorderedVars = + listedInExposing + |> List.filter inDocs + |> List.map (\( pre, _, post ) -> pre ++ post) + |> List.concat + in + if List.isEmpty listedInDocs && forceMultiline then + ( List.map List.singleton remainingFromExposing, commentsFromReorderedVars ) + + else + ( listedInDocs + ++ (if List.isEmpty remainingFromExposing then + [] + + else + [ remainingFromExposing ] + ) + , commentsFromReorderedVars + ) + + +formatModuleHeader : Bool -> M.Module -> List Box +formatModuleHeader addDefaultHeader modu = + let + maybeHeader : Maybe M.Header + maybeHeader = + if addDefaultHeader then + Just (Maybe.withDefault M.defaultHeader modu.header) + + else + modu.header + + refName ref = + case ref of + VarRef _ name -> + name + + TagRef _ name -> + name + + OpRef name -> + name + + documentedVars : List (List String) + documentedVars = + -- TODO + -- modu.header + -- |> Maybe.andThen (.docs >> Result.toMaybe) + -- |> Maybe.toList + -- |> List.concatMap extractDocs + [] + + documentedVarsSet : EverySet String String + documentedVarsSet = + EverySet.fromList identity (List.concat documentedVars) + + extractDocs : Markdown.Block -> List (List String) + extractDocs block = + case block of + Markdown.ElmDocs vars -> + List.map (List.map (refName << textToRef)) vars + + _ -> + [] + + textToRef : String -> Ref (List String) + textToRef text = + case String.toList text of + c :: [] -> + if Char.isUpper c then + TagRef [] text + + else + VarRef [] text + + [ '(', a, ')' ] -> + OpRef (String.fromChar a) + + [ '(', a, b, ')' ] -> + OpRef (String.fromList [ a, b ]) + + _ -> + VarRef [] text + + definedVars : EverySet String ( List Space.Comment, Src.Exposed, List Space.Comment ) + definedVars = + modu.decls + |> List.concatMap extractVarName + |> List.map (\varName -> ( [], varName, [] )) + |> EverySet.fromList + (\( _, exposed, _ ) -> + case exposed of + Src.Lower (A.At _ name) -> + name + + Src.Operator _ name -> + name + + Src.Upper (A.At _ name) _ -> + name + ) + + exportsList = + Maybe.withDefault M.defaultHeader maybeHeader + |> .exports + |> (\( _, v, _ ) -> v) + + detailedListingToSet : Src.Exposing -> EverySet String ( List Space.Comment, Src.Exposed, List Space.Comment ) + detailedListingToSet listing = + case listing of + Src.Open -> + EverySet.empty + + Src.Explicit exposedList -> + exposedList + |> List.map (\exposed -> ( [], exposed, [] )) + |> EverySet.fromList + (\( _, exposed, _ ) -> + case exposed of + Src.Lower (A.At _ name) -> + name + + Src.Operator _ name -> + name + + Src.Upper (A.At _ name) _ -> + name + ) + + detailedListingIsMultiline : A.Located Src.Exposing -> Bool + detailedListingIsMultiline listing = + case listing of + A.At region (Src.Explicit _) -> + A.isMultiline region + + A.At _ Src.Open -> + False + + varsToExpose : EverySet String ( List Space.Comment, Src.Exposed, List Space.Comment ) + varsToExpose = + case Maybe.map .exports maybeHeader of + Nothing -> + if List.all List.isEmpty documentedVars then + definedVars + + else + EverySet.filter + (\( _, v, _ ) -> + EverySet.member identity + (case v of + Src.Lower (A.At _ name) -> + name + + Src.Operator _ name -> + name + + Src.Upper (A.At _ name) _ -> + name + ) + documentedVarsSet + ) + definedVars + + Just ( _, A.At _ e, _ ) -> + detailedListingToSet e + + sortedExports : ( List (List ( List Space.Comment, Src.Exposed, List Space.Comment )), List Space.Comment ) + sortedExports = + sortVars + (detailedListingIsMultiline exportsList) + varsToExpose + documentedVars + + extractVarName : Decl.Decl -> List Src.Exposed + extractVarName decl = + case decl of + Decl.Value _ _ (A.At _ (Src.Value name _ _ _)) -> + [ Src.Lower name ] + + Decl.Union _ (A.At _ (Src.Union name _ _)) -> + [ Src.Upper name (Src.Public A.zero) ] + + Decl.Alias _ (A.At _ (Src.Alias name _ _)) -> + [ Src.Upper name Src.Private ] + + Decl.Port _ (Src.Port name _) -> + [ Src.Lower name ] + + formatModuleLine_ : M.Header -> Box + formatModuleLine_ header = + let + ( preExposing, _, postExposing ) = + header.exports + in + formatModuleLine sortedExports header.effects header.name preExposing postExposing + + -- docs = + -- fmap (formatDocComment (ImportInfo.fromModule mempty modu)) <| AST.Module.docs modu + -- docs = + -- modu.header + -- |> Maybe.andThen (.docs >> Result.toMaybe) + -- |> Maybe.map (formatDocComment (ImportInfo.fromModule KnownContents.mempty modu)) + imports = + formatImports modu + in + List.intersperse Box.blankLine + (List.concat + [ Maybe.toList (Maybe.map formatModuleLine_ maybeHeader) + + -- , Maybe.toList docs + , if List.isEmpty imports then + [] + + else + [ imports ] + ] + ) + + +formatImports : M.Module -> List Box +formatImports modu = + let + comments : Comments + comments = + -- TODO + [] + + imports : List Src.Import + imports = + modu.imports + in + [ formatComments comments + |> Maybe.toList + , imports + |> Map.assocs + |> fmap (\( name, C pre method ) -> formatImport ( C pre name, method )) + ] + |> List.filter (not << List.isEmpty) + |> List.intersperse [ Box.blankLine ] + |> List.concat + + +formatModuleLine : + ( List (List (C2 Src.Exposed)), List Space.Comment ) + -> M.Effects + -> ( List Space.Comment, A.Located Name.Name, List Space.Comment ) + -> List Space.Comment + -> List Space.Comment + -> Box +formatModuleLine ( varsToExpose, extraComments ) srcTag ( preName, A.At _ name, postName ) preExposing postExposing = + let + tag = + case srcTag of + M.NoEffects _ -> + Box.line (Box.keyword "module") + + M.Ports _ -> + let + comments = + -- TODO + [] + in + ElmStructure.spaceSepOrIndented + (formatTailCommented ( comments, Box.line (Box.keyword "port") )) + [ Box.line (Box.keyword "module") ] + + M.Manager _ _ -> + let + comments = + -- TODO + [] + in + ElmStructure.spaceSepOrIndented + (formatTailCommented ( comments, Box.line (Box.keyword "effect") )) + [ Box.line (Box.keyword "module") ] + + exports = + case varsToExpose of + [] -> + Box.line (Box.keyword "(..)") + + [ oneGroup ] -> + oneGroup + |> List.map (formatCommented << c2map formatVarValue) + |> ElmStructure.group_ False "(" "," (Maybe.toList (formatComments extraComments)) ")" False + + _ -> + varsToExpose + |> List.map (formatCommented << c2map (ElmStructure.group False "" "," "" False << List.map formatVarValue) << sequenceAC2) + |> ElmStructure.group_ False "(" "," (Maybe.toList (formatComments extraComments)) ")" True + + formatSetting : ( ( List Space.Comment, String, List Space.Comment ), ( List Space.Comment, String, List Space.Comment ) ) -> Box + formatSetting ( k, v ) = + formatRecordPair "=" (Box.line << formatUppercaseIdentifier) ( k, v, False ) + + formatSettings : List ( ( List Space.Comment, String, List Space.Comment ), ( List Space.Comment, String, List Space.Comment ) ) -> Box + formatSettings settings = + List.map formatSetting settings + |> ElmStructure.group True "{" "," "}" False + + whereClause : List Box + whereClause = + case srcTag of + M.NoEffects _ -> + [] + + M.Ports _ -> + [] + + M.Manager _ manager -> + let + settings : List ( ( List Space.Comment, String, List Space.Comment ), ( List Space.Comment, Name.Name, List Space.Comment ) ) + settings = + case manager of + Src.Cmd (A.At _ cmdType) -> + [ ( ( [], "command", [] ), ( [], cmdType, [] ) ) ] + + Src.Sub (A.At _ subType) -> + [ ( ( [], "subscription", [] ), ( [], subType, [] ) ) ] + + Src.Fx (A.At _ cmdType) (A.At _ subType) -> + [ ( ( [], "command", [] ), ( [], cmdType, [] ) ) + , ( ( [], "subscription", [] ), ( [], subType, [] ) ) + ] + in + -- TODO add comments around manager/settings (`where` part) + [ formatKeywordCommented "where" ( [], formatSettings settings, [] ) ] + + nameClause = + case + ( tag + , formatCommented ( preName, Box.line (formatQualifiedUppercaseIdentifier (String.split "." name)), postName ) + ) + of + ( Box.SingleLine tag_, Box.SingleLine name_ ) -> + Box.line + (Box.row + [ tag_ + , Box.space + , name_ + ] + ) + + ( tag_, name_ ) -> + Box.stack1 + [ tag_ + , Box.indent name_ + ] + in + ElmStructure.spaceSepOrIndented + (ElmStructure.spaceSepOrIndented + nameClause + (whereClause ++ [ formatCommented ( preExposing, Box.line (Box.keyword "exposing"), postExposing ) ]) + ) + [ exports ] + + +formatModule : Bool -> Int -> M.Module -> Box +formatModule addDefaultHeader spacing modu = + let + initialComments_ = + case modu.initialComments of + [] -> + [] + + comments -> + List.map formatComment comments + ++ [ Box.blankLine, Box.blankLine ] + + spaceBeforeBody : Int + spaceBeforeBody = + case ( modu.decls, Maybe.andThen (.docs >> Result.toMaybe) modu.header ) of + ( [], _ ) -> + 0 + + ( _, Just _ ) -> + spacing + 1 + + _ -> + spacing + + decls = + modu.decls + -- TODO review + |> List.map Entry + in + Box.stack1 + (List.concat + [ initialComments_ + , formatModuleHeader addDefaultHeader modu + , List.repeat spaceBeforeBody Box.blankLine + , Maybe.toList (formatModuleBody spacing (ImportInfo.fromModule KnownContents.mempty modu) decls) + ] + ) + + +formatModuleBody : Int -> ImportInfo -> List (TopLevelStructure Decl.Decl) -> Maybe Box +formatModuleBody linesBetween importInfo body = + let + entryType : Decl.Decl -> BodyEntryType + entryType adecl = + case adecl of + -- CommonDeclaration def -> + -- case extract (I.unFix def) of + -- Definition pat _ _ _ -> + -- case extract (I.unFix pat) of + -- VarPattern name -> + -- BodyNamed (VarRef () name) + -- OpPattern name -> + -- BodyNamed (OpRef name) + -- _ -> + -- BodyUnnamed + -- TypeAnnotation (C _ name) _ -> + -- BodyNamed name + -- Datatype (C _ (NameWithArgs name _)) _ -> + -- BodyNamed (TagRef () name) + -- TypeAlias _ (C _ (NameWithArgs name _)) _ -> + -- BodyNamed (TagRef () name) + -- PortAnnotation (C _ name) _ _ -> + -- BodyNamed (VarRef () name) + -- Fixity _ _ _ _ -> + -- BodyFixity + Decl.Value _ _ (A.At _ (Src.Value (A.At _ name) _ _ _)) -> + BodyNamed (VarRef () name) + + Decl.Union _ (A.At _ (Src.Union (A.At _ name) _ _)) -> + BodyNamed (TagRef () name) + + Decl.Alias _ (A.At _ (Src.Alias (A.At _ name) _ _)) -> + BodyNamed (TagRef () name) + + Decl.Port _ (Src.Port (A.At _ name) _) -> + BodyNamed (VarRef () name) + in + formatTopLevelBody linesBetween importInfo <| + List.map (topLevelStructureMap (\b -> ( entryType b, formatDeclaration importInfo b ))) body + + +type BodyEntryType + = BodyNamed (Ref ()) + | BodyUnnamed + | BodyFixity + + +type Ref ns + = VarRef ns String + | TagRef ns String + | OpRef String + + +refMap : (a -> b) -> Ref a -> Ref b +refMap f ref = + case ref of + VarRef namespace name -> + VarRef (f namespace) name + + TagRef namespace name -> + TagRef (f namespace) name + + OpRef name -> + OpRef name + + +type TopLevelStructure a + = DocComment Markdown.Blocks + | BodyComment Space.Comment + | Entry a + + +topLevelStructureMap : (a -> b) -> TopLevelStructure a -> TopLevelStructure b +topLevelStructureMap f topLevelStructure = + case topLevelStructure of + DocComment blocks -> + DocComment blocks + + BodyComment comment -> + BodyComment comment + + Entry a -> + Entry (f a) + + +formatTopLevelBody : + Int + -> ImportInfo + -> List (TopLevelStructure ( BodyEntryType, Box )) + -> Maybe Box +formatTopLevelBody linesBetween importInfo body = + let + extraLines : Int -> List Box + extraLines n = + List.repeat n Box.blankLine + + spacer : TopLevelStructure ( BodyEntryType, Box ) -> TopLevelStructure ( BodyEntryType, Box ) -> Int + spacer a b = + case ( declarationType (topLevelStructureMap Tuple.first a), declarationType (topLevelStructureMap Tuple.first b) ) of + ( DStarter, _ ) -> + 0 + + ( _, DCloser ) -> + 0 + + ( DComment, DComment ) -> + 0 + + ( _, DComment ) -> + if linesBetween == 1 then + 1 + + else + linesBetween + 1 + + ( DComment, DDefinition _ ) -> + if linesBetween == 1 then + 0 + + else + linesBetween + + ( DComment, _ ) -> + linesBetween + + ( DDocComment, DDefinition _ ) -> + 0 + + ( DDefinition Nothing, DDefinition (Just _) ) -> + linesBetween + + ( DDefinition _, DStarter ) -> + linesBetween + + ( DDefinition Nothing, DDefinition Nothing ) -> + linesBetween + + ( DDefinition a_, DDefinition b_ ) -> + if a_ == b_ then + 0 + + else + linesBetween + + ( DCloser, _ ) -> + linesBetween + + ( _, DDocComment ) -> + linesBetween + + ( DDocComment, DStarter ) -> + 0 + + ( DFixity, DFixity ) -> + 0 + + ( DFixity, _ ) -> + linesBetween + + ( _, DFixity ) -> + linesBetween + + boxes : List Box + boxes = + intersperseMap (\a b -> extraLines (spacer a b)) + (formatTopLevelStructure importInfo << topLevelStructureMap Tuple.second) + body + in + case boxes of + [] -> + Nothing + + _ -> + Just (Box.stack1 boxes) + + +pairs : List a -> List ( a, a ) +pairs input = + let + step next ( prev, acc ) = + case prev of + Nothing -> + ( Just next, acc ) + + Just prev_ -> + ( Just next, ( next, prev_ ) :: acc ) + in + List.foldr step ( Nothing, [] ) input + |> Tuple.second + + +intersperseMap : (a -> a -> List b) -> (a -> b) -> List a -> List b +intersperseMap spacer fn list = + case list of + [] -> + [] + + first :: _ -> + fn first + :: (pairs list + |> List.concatMap (\( a, b ) -> spacer a b ++ [ fn b ]) + ) + + + +-- type ElmCodeBlock annf ns +-- = DeclarationsCode (List (TopLevelStructure (ASTNS annf ns TopLevelDeclarationNK))) +-- | ExpressionsCode (List (TopLevelStructure (C0Eol (ASTNS annf ns ExpressionNK)))) +-- | ModuleCode (AST.Module.Module ns (ASTNS annf ns TopLevelNK)) +-- convertElmCodeBlock : (ann -> ann_) -> ElmCodeBlock ann ns -> ElmCodeBlock ann_ ns +-- convertElmCodeBlock f elmCodeBlock = +-- case elmCodeBlock of +-- DeclarationsCode decls -> +-- DeclarationsCode (fmap (fmap (I.convert f)) decls) +-- ExpressionsCode exprs -> +-- ExpressionsCode (fmap (fmap (fmap (I.convert f))) exprs) +-- ModuleCode mod -> +-- ModuleCode (fmap (I.convert f) mod) +-- -- TODO: there must be an existing haskell function that does this, right? +-- firstOf : List (a -> Maybe b) -> a -> Maybe b +-- firstOf options value = +-- case options of +-- [] -> +-- Nothing +-- next :: rest -> +-- case next value of +-- Just result -> +-- Just result +-- Nothing -> +-- firstOf rest value + + +formatDocComment : ImportInfo -> Markdown.Blocks -> Box +formatDocComment importInfo blocks = + -- let + -- parse : String -> Maybe (ElmCodeBlock Identity (List UppercaseIdentifier)) + -- parse source = + -- source + -- |> firstOf + -- [ fmap DeclarationsCode << Result.toMaybe << Parse.parseDeclarations + -- , fmap ExpressionsCode << Result.toMaybe << Parse.parseExpressions + -- , fmap ModuleCode << Result.toMaybe << Parse.parseModule + -- ] + -- |> fmap (convertElmCodeBlock (pure << extract)) + -- format : ElmCodeBlock annf (List UppercaseIdentifier) -> String + -- format result = + -- case result of + -- ModuleCode modu -> + -- formatModule False 1 modu + -- |> (Text.unpack << Box.render) + -- DeclarationsCode declarations -> + -- formatModuleBody 1 importInfo declarations + -- |> fmap (Text.unpack << Box.render) + -- |> fromMaybe "" + -- ExpressionsCode expressions -> + -- expressions + -- |> fmap (fmap (fmap (I.convert (Identity << extract)))) + -- |> fmap (fmap (formatEolCommented << fmap (syntaxParens SyntaxSeparated << formatExpression importInfo))) + -- |> fmap (fmap (Tuple.pair BodyUnnamed)) + -- |> formatTopLevelBody 1 importInfo + -- |> fmap (Text.unpack << Box.render) + -- |> fromMaybe "" + -- content : String + -- content = + -- ElmFormat.Render.Markdown.formatMarkdown (fmap format << parse) (fmap cleanBlock blocks) + -- cleanBlock : Markdown.Block -> Markdown.Block + -- cleanBlock block = + -- case block of + -- Markdown.ElmDocs docs -> + -- Markdown.ElmDocs + -- ((fmap << fmap) + -- (Text.replace (Text.pack "(..)") (Text.pack "")) + -- docs + -- ) + -- _ -> + -- block + -- in + -- formatDocCommentString content + Debug.todo "formatDocComment" + + + +-- formatDocCommentString : String -> Box +-- formatDocCommentString docs = +-- case lines docs of +-- [] -> +-- line (row [ punc "{-|", space, punc "-}" ]) +-- [ first ] -> +-- stack1 +-- [ line (row [ punc "{-|", space, literal first ]) +-- , line (punc "-}") +-- ] +-- first :: rest -> +-- line (row [ punc "{-|", space, literal first ]) +-- |> andThen (map (line << literal) rest) +-- |> andThen [ line <| punc "-}" ] + + +formatImport : Src.Import -> Box +formatImport (Src.Import (A.At _ importName) maybeAlias exposing_) = + -- formatImport ( (C _ rawName) as name, method ) = + let + requestedAs = + maybeAlias + |> Maybe.andThen + (\aliasName -> + if aliasName == importName then + Nothing + + else + Just aliasName + ) + + asVar = + requestedAs + |> Maybe.map + (formatImportClause + (Just << Box.line << formatUppercaseIdentifier) + "as" + ) + |> Maybe.join + + exposingVar = + formatImportClause + (formatListing formatDetailedListing) + "exposing" + (AST.Module.exposedVars method) + + formatImportClause : (a -> Maybe Box) -> String -> C2 beforeKeyword afterKeyword a -> Maybe Box + formatImportClause format keyw input = + case fmap format input of + C ( [], [] ) Nothing -> + Nothing + + C ( preKeyword, postKeyword ) (Just listing_) -> + case + ( formatPreCommented (C preKeyword (line (keyword keyw))) + , formatPreCommented (C postKeyword listing_) + ) + of + ( SingleLine keyword_, SingleLine listing__ ) -> + Just + (line + (row + [ keyword_ + , space + , listing__ + ] + ) + ) + + ( keyword_, listing__ ) -> + Just + (stack1 + [ keyword_ + , indent listing__ + ] + ) + + _ -> + Just (pleaseReport "UNEXPECTED IMPORT" "import clause comments with no clause") + in + case + ( formatPreCommented (fmap (Box.line << formatQualifiedUppercaseIdentifier) name) + , asVar + , exposingVar + ) + of + ( Box.SingleLine name_, Just (Box.SingleLine as_), Just (Box.SingleLine exposing_) ) -> + Box.line <| + Box.row + [ Box.keyword "import" + , Box.space + , name_ + , Box.space + , as_ + , Box.space + , exposing_ + ] + + ( Box.SingleLine name_, Just (Box.SingleLine as_), Nothing ) -> + Box.line <| + Box.row + [ Box.keyword "import" + , Box.space + , name_ + , Box.space + , as_ + ] + + ( Box.SingleLine name_, Nothing, Just (Box.SingleLine exposing_) ) -> + Box.line <| + Box.row + [ Box.keyword "import" + , Box.space + , name_ + , Box.space + , exposing_ + ] + + ( Box.SingleLine name_, Nothing, Nothing ) -> + Box.line <| + Box.row + [ Box.keyword "import" + , Box.space + , name_ + ] + + ( Box.SingleLine name_, Just (Box.SingleLine as_), Just exposing_ ) -> + Box.stack1 + [ Box.line <| + Box.row + [ Box.keyword "import" + , Box.space + , name_ + , Box.space + , as_ + ] + , Box.indent exposing_ + ] + + ( Box.SingleLine name_, Just as_, Just exposing_ ) -> + Box.stack1 + [ Box.line <| + Box.row + [ Box.keyword "import" + , Box.space + , name_ + ] + , Box.indent as_ + , Box.indent exposing_ + ] + + ( Box.SingleLine name_, Nothing, Just exposing_ ) -> + Box.stack1 + [ Box.line <| + Box.row + [ Box.keyword "import" + , Box.space + , name_ + ] + , Box.indent exposing_ + ] + + ( name_, Just as_, Just exposing_ ) -> + Box.stack1 + [ Box.line <| Box.keyword "import" + , Box.indent name_ + , Box.indent <| Box.indent as_ + , Box.indent <| Box.indent exposing_ + ] + + ( name_, Nothing, Just exposing_ ) -> + Box.stack1 + [ Box.line <| Box.keyword "import" + , Box.indent name_ + , Box.indent <| Box.indent exposing_ + ] + + ( name_, Just as_, Nothing ) -> + Box.stack1 + [ Box.line <| Box.keyword "import" + , Box.indent name_ + , Box.indent <| Box.indent as_ + ] + + ( name_, Nothing, Nothing ) -> + Box.stack1 + [ Box.line <| Box.keyword "import" + , Box.indent name_ + ] + + +formatListing : Src.Privacy -> Maybe Box +formatListing listing = + case listing of + Src.Private -> + Nothing + + Src.Public _ -> + -- TODO comments + Just (parens (formatCommented ( [], Box.line (Box.keyword ".."), [] ))) + + + +-- formatDetailedListing : AST.Module.DetailedListing -> List Box +-- formatDetailedListing listing = +-- concat +-- [ formatCommentedMap +-- (\name () -> AST.Listing.OpValue name) +-- formatVarValue +-- (AST.Module.operators listing) +-- , formatCommentedMap +-- (\name (C inner listing_) -> AST.Listing.Union (C inner name) listing_) +-- formatVarValue +-- (AST.Module.types listing) +-- , formatCommentedMap +-- (\name () -> AST.Listing.Value name) +-- formatVarValue +-- (AST.Module.values listing) +-- ] +-- formatCommentedMap : (k -> v -> a) -> (a -> Box) -> AST.Listing.CommentedMap k v -> List Box +-- formatCommentedMap construct format values = +-- let +-- format_ ( k, C c v ) = +-- formatCommented (C c (format (construct k v))) +-- in +-- values +-- |> Map.assocs +-- |> fmap format_ + + +formatVarValue : Src.Exposed -> Box +formatVarValue aval = + case aval of + Src.Lower (A.At _ val) -> + Box.line (formatLowercaseIdentifier [] val) + + Src.Operator _ name -> + Box.line (Box.identifier ("(" ++ name ++ ")")) + + Src.Upper (A.At _ name) privacy -> + case + ( formatListing privacy + -- TODO post-comments on `name` + , formatTailCommented ( [], Box.line (formatUppercaseIdentifier name) ) + ) + of + ( Just _, _ ) -> + formatTailCommented <| + -- TODO post-comments on `name` + ( [], Box.line (Box.row [ formatUppercaseIdentifier name, Box.keyword "(..)" ]) ) + + ( Nothing, name_ ) -> + name_ + + +formatTopLevelStructure : ImportInfo -> TopLevelStructure Box -> Box +formatTopLevelStructure importInfo topLevelStructure = + case topLevelStructure of + DocComment docs -> + formatDocComment importInfo docs + + BodyComment c -> + formatComment c + + Entry entry -> + entry + + +formatCommonDeclaration : ImportInfo -> A.Located Src.Value -> Box +formatCommonDeclaration importInfo (A.At _ (Src.Value (A.At _ name) args expr _)) = + -- case decl of + -- Definition name args comments expr -> + -- formatDefinition importInfo name args comments expr + -- TypeAnnotation name typ -> + -- formatTypeAnnotation name typ + formatDefinition importInfo name args [] expr + + +formatDeclaration : ImportInfo -> Decl.Decl -> Box +formatDeclaration importInfo decl = + case decl of + -- CommonDeclaration def -> + -- formatCommonDeclaration importInfo def + -- Datatype nameWithArgs tags -> + -- let + -- ctor (NameWithArgs tag args_) = + -- case allSingles <| map (formatPreCommented .fmap (typeParens ForCtor << formatType)) args_ of + -- Ok args__ -> + -- Box.line <| Box.row <| List.intersperse space <| formatUppercaseIdentifier tag :: args__ + -- Err [] -> + -- Box.line <| formatUppercaseIdentifier tag + -- Err args__ -> + -- Box.stack1 + -- [ Box.line <| formatUppercaseIdentifier tag + -- , Box.stack1 args__ + -- |> indent + -- ] + -- in + -- case + -- formatOpenCommentedList <| fmap ctor tags + -- of + -- [] -> + -- error "List can't be empty" + -- first :: rest -> + -- case formatCommented <| fmap formatNameWithArgs nameWithArgs of + -- SingleLine nameWithArgs_ -> + -- Box.stack1 + -- [ Box.line <| + -- Box.row + -- [ Box.keyword "type" + -- , space + -- , nameWithArgs_ + -- ] + -- , first + -- |> prefix (Box.row [ punc "=", space ]) + -- |> andThen (map (prefix (Box.row [ punc "|", space ])) rest) + -- |> indent + -- ] + -- nameWithArgs_ -> + -- Box.stack1 + -- [ Box.line <| Box.keyword "type" + -- , Box.indent nameWithArgs_ + -- , first + -- |> Box.prefix (Box.row [ Box.punc "=", Box.space ]) + -- |> andThen (map (prefix (Box.row [ Box.punc "|", Box.space ])) rest) + -- |> Box.indent + -- ] + -- TypeAlias preAlias nameWithArgs typ -> + -- ElmStructure.definition "=" + -- True + -- (Box.line (Box.keyword "type")) + -- [ formatPreCommented (C preAlias (Box.line (Box.keyword "alias"))) + -- , formatCommented <| fmap formatNameWithArgs nameWithArgs + -- ] + -- (formatPreCommentedStack <| fmap (typeParens NotRequired << formatType) typ) + -- PortAnnotation name typeComments typ -> + -- ElmStructure.definition ":" + -- False + -- (Box.line (Box.keyword "port")) + -- [ formatCommented (fmap (Box.line << formatLowercaseIdentifier []) name) ] + -- (formatCommentedApostrophe typeComments (typeParens NotRequired (formatType typ))) + -- Fixity assoc precedence name value -> + -- let + -- formatAssoc a = + -- case a of + -- L -> + -- Box.keyword "left " + -- R -> + -- Box.keyword "right" + -- N -> + -- Box.keyword "non " + -- in + -- ElmStructure.spaceSepOrIndented + -- (Box.line (Box.keyword "infix")) + -- [ formatPreCommented (fmap (Box.line << formatAssoc) assoc) + -- , formatPreCommented (fmap (Box.line << Box.literal << show) precedence) + -- , formatCommented (fmap (Box.line << formatSymbolIdentifierInParens) name) + -- , Box.line (Box.keyword "=") + -- , formatPreCommented (fmap (Box.line << Box.identifier << formatVarName) value) + -- ] + Decl.Value _ _ value -> + formatCommonDeclaration importInfo value + + Decl.Union _ (A.At _ (Src.Union name args tags)) -> + let + tags_ : OpenCommentedList ( A.Located Name, List Src.Type ) + tags_ = + case tags of + firstTag :: restTags -> + OpenCommentedList (List.map (\tag -> ( ( [], [], Nothing ), tag )) restTags) + ( [], Nothing, firstTag ) + + _ -> + Debug.todo "tags" + + ctor : ( A.Located Name, List Src.Type ) -> Box + ctor ( A.At _ tag, args_ ) = + case Box.allSingles (List.map (\arg -> formatPreCommented ( [], typeParens ForCtor (formatType arg) )) args_) of + Ok args__ -> + Box.line <| Box.row <| List.intersperse Box.space <| formatUppercaseIdentifier tag :: args__ + + Err [] -> + Box.line (formatUppercaseIdentifier tag) + + Err args__ -> + Box.stack1 + [ Box.line (formatUppercaseIdentifier tag) + , Box.stack1 args__ + |> Box.indent + ] + in + case formatOpenCommentedList (openCommentedListMap ctor tags_) of + [] -> + crash "List can't be empty" + + first :: rest -> + -- TODO add comments surrounding name+args + case formatCommented ( [], formatNameWithArgs (A.toValue name) (List.map (\(A.At _ arg) -> ( [], arg )) args), [] ) of + Box.SingleLine nameWithArgs_ -> + Box.stack1 + [ Box.line <| + Box.row + [ Box.keyword "type" + , Box.space + , nameWithArgs_ + ] + , first + |> Box.prefix (Box.row [ Box.punc "=", Box.space ]) + |> Box.andThen (List.map (Box.prefix (Box.row [ Box.punc "|", Box.space ])) rest) + |> Box.indent + ] + + nameWithArgs_ -> + Box.stack1 + [ Box.line <| Box.keyword "type" + , Box.indent nameWithArgs_ + , first + |> Box.prefix (Box.row [ Box.punc "=", Box.space ]) + |> Box.andThen (List.map (Box.prefix (Box.row [ Box.punc "|", Box.space ])) rest) + |> Box.indent + ] + + Decl.Alias _ _ -> + Debug.todo "formatDeclaration3" + + Decl.Port _ _ -> + Debug.todo "formatDeclaration4" + + +formatNameWithArgs : Name -> List (C1 Name) -> Box +formatNameWithArgs name args = + case Box.allSingles <| List.map (formatPreCommented << c1map (Box.line << formatLowercaseIdentifier [])) args of + Ok args_ -> + Box.line (Box.row (List.intersperse Box.space (formatUppercaseIdentifier name :: args_))) + + Err args_ -> + Box.stack1 + ((Box.line <| formatUppercaseIdentifier name) + :: List.map Box.indent args_ + ) + + +formatDefinition : ImportInfo -> Name -> List Src.Pattern -> Comments -> Src.Expr -> Box +formatDefinition importInfo name args comments expr = + let + body = + Box.stack1 + (List.concat + [ List.map formatComment comments + , [ syntaxParens SyntaxSeparated (formatExpression importInfo expr) ] + ] + ) + in + ElmStructure.definition "=" + True + (syntaxParens SpaceSeparated (formatPattern (Src.PVar name))) + (List.map (\(A.At _ y) -> formatCommentedApostrophe [] (syntaxParens SpaceSeparated (formatPattern y))) args) + body + + +formatTypeAnnotation : C1 (Ref ()) -> C1 Src.Type -> Box +formatTypeAnnotation name typ = + ElmStructure.definition ":" + False + (formatTailCommented (c1map (Box.line << formatVar << refMap (\() -> [])) name)) + [] + (formatPreCommented (c1map (typeParens NotRequired << formatType) typ)) + + +formatPattern : Src.Pattern_ -> ( SyntaxContext, Box ) +formatPattern apattern = + case apattern of + -- Anything -> + -- Tuple.pair SyntaxSeparated (line (keyword "_")) + -- UnitPattern comments -> + -- Tuple.pair SyntaxSeparated (formatUnit '(' ')' comments) + -- LiteralPattern lit -> + -- Tuple.pair SyntaxSeparated (formatLiteral lit) + -- VarPattern var -> + -- Tuple.pair SyntaxSeparated (line (formatLowercaseIdentifier [] var)) + -- OpPattern (SymbolIdentifier name) -> + -- Tuple.pair SyntaxSeparated (line (identifier ("(" ++ name ++ ")"))) + -- ConsPattern first rest -> + -- let + -- formatRight (C ( preOp, postOp, eol ) term) = + -- ( False + -- , preOp + -- , line (punc "::") + -- , formatC2Eol + -- ((fmap <| syntaxParens SpaceSeparated << formatPattern ) + -- (C ( postOp, [], eol ) term) + -- ) + -- ) + -- in + -- Tuple.pair SpaceSeparated + -- (formatBinary False + -- (formatEolCommented <| fmap (syntaxParens SpaceSeparated << formatPattern ) first) + -- (formatRight (toCommentedList rest)) + -- ) + -- DataPattern ( ns, tag ) [] -> + -- let + -- ctor = + -- ns ++ [ tag ] + -- in + -- line (formatQualifiedUppercaseIdentifier ctor) + -- |> Tuple.pair SyntaxSeparated + -- DataPattern ( ns, tag ) patterns -> + -- let + -- ctor = + -- ns ++ [ tag ] + -- in + -- Tuple.pair SpaceSeparated + -- (ElmStructure.application + -- (FAJoinFirst JoinAll) + -- (line (formatQualifiedUppercaseIdentifier ctor)) + -- (fmap (formatPreCommented << fmap (syntaxParens SpaceSeparated << formatPattern )) patterns) + -- ) + -- PatternParens pattern -> + -- formatCommented (fmap (syntaxParens SyntaxSeparated << formatPattern ) pattern) + -- |> parens + -- |> Tuple.pair SyntaxSeparated + -- TuplePattern patterns -> + -- Tuple.pair SyntaxSeparated <| + -- ElmStructure.group True "(" "," ")" False <| + -- fmap (formatCommented << fmap (syntaxParens SyntaxSeparated << formatPattern )) patterns + -- EmptyListPattern comments -> + -- Tuple.pair SyntaxSeparated <| + -- formatUnit '[' ']' comments + -- ListPattern patterns -> + -- Tuple.pair SyntaxSeparated <| + -- ElmStructure.group True "[" "," "]" False <| + -- fmap (formatCommented << fmap (syntaxParens SyntaxSeparated << formatPattern )) patterns + -- EmptyRecordPattern comments -> + -- Tuple.pair SyntaxSeparated <| + -- formatUnit '{' '}' comments + -- RecordPattern fields -> + -- Tuple.pair SyntaxSeparated <| + -- ElmStructure.group True "{" "," "}" False <| + -- map (formatCommented << fmap (line << formatLowercaseIdentifier [])) fields + -- Alias pattern name -> + -- Tuple.pair SpaceSeparated <| + -- case + -- ( formatTailCommented <| fmap (syntaxParens SpaceSeparated << formatPattern ) pattern + -- , formatPreCommented <| fmap (line << formatLowercaseIdentifier []) name + -- ) + -- of + -- ( SingleLine pattern_, SingleLine name_ ) -> + -- line <| + -- row + -- [ pattern_ + -- , space + -- , keyword "as" + -- , space + -- , name_ + -- ] + -- ( pattern_, name_ ) -> + -- stack1 + -- [ pattern_ + -- , line <| keyword "as" + -- , indent name_ + -- ] + Src.PAnything name -> + ( SyntaxSeparated, Box.line (Box.identifier ("_" ++ name)) ) + + Src.PVar name -> + ( SyntaxSeparated, Box.line (formatLowercaseIdentifier [] name) ) + + Src.PRecord fields -> + Debug.todo "formatPattern.PRecord" + + Src.PAlias aliasPattern name -> + Debug.todo "formatPattern.PAlias" + + Src.PUnit -> + Debug.todo "formatPattern.PUnit" + + Src.PTuple a b cs -> + Debug.todo "formatPattern.PTuple" + + Src.PCtor nameRegion name patterns -> + Debug.todo "formatPattern.PCtor" + + Src.PCtorQual nameRegion home name patterns -> + Debug.todo "formatPattern.PCtorQual" + + Src.PList patterns -> + Debug.todo "formatPattern.PList" + + Src.PCons hd tl -> + Debug.todo "formatPattern.PCons" + + Src.PChr chr -> + Debug.todo "formatPattern.PChr" + + Src.PStr str -> + Debug.todo "formatPattern.PStr" + + Src.PInt int -> + Debug.todo "formatPattern.PInt" + + +formatRecordPair : String -> (v -> Box) -> ( ( List Space.Comment, String, List Space.Comment ), ( List Space.Comment, v, List Space.Comment ), Bool ) -> Box +formatRecordPair delim formatValue ( ( pre, k, postK ), ( preV, v, postV ), forceMultiline ) = + formatPreCommented + ( pre + , ElmStructure.equalsPair delim + forceMultiline + (formatCommented ( [], Box.line (formatLowercaseIdentifier [] k), postK )) + (formatCommented ( preV, formatValue v, postV )) + ) + + + +-- formatPair : String -> Pair Line Box -> Box +-- formatPair delim (Pair a b (ForceMultiline forceMultiline)) = +-- ElmStructure.equalsPair delim +-- forceMultiline +-- (formatTailCommented <| fmap line a) +-- (formatPreCommented b) +-- negativeCasePatternWorkaround : ASTNS annf (List UppercaseIdentifier) PatternNK -> Box -> Box +-- negativeCasePatternWorkaround pattern = +-- case extract <| I.unFix pattern of +-- LiteralPattern (IntNum i _) -> +-- if i < 0 then +-- parens +-- else +-- id +-- LiteralPattern (FloatNum f _) -> +-- if f < 0 then +-- parens +-- else +-- id +-- _ -> +-- id + + +type SyntaxContext + = SyntaxSeparated + | InfixSeparated + | SpaceSeparated + | AmbiguousEnd + + +syntaxParens : SyntaxContext -> ( SyntaxContext, Box ) -> Box +syntaxParens outer ( inner, box ) = + let + parensIf bool = + if bool then + parens + + else + identity + in + parensIf (needsParensInContext inner outer) box + + +needsParensInContext : SyntaxContext -> SyntaxContext -> Bool +needsParensInContext inner outer = + case ( inner, outer ) of + ( SpaceSeparated, SpaceSeparated ) -> + True + + ( InfixSeparated, SpaceSeparated ) -> + True + + ( InfixSeparated, InfixSeparated ) -> + True + + ( AmbiguousEnd, SpaceSeparated ) -> + True + + ( AmbiguousEnd, InfixSeparated ) -> + True + + ( InfixSeparated, AmbiguousEnd ) -> + True + + _ -> + False + + +formatExpression : ImportInfo -> Src.Expr -> ( SyntaxContext, Box ) +formatExpression importInfo (A.At _ aexpr) = + case aexpr of + -- Literal lit -> + -- Tuple.pair SyntaxSeparated <| formatLiteral lit + -- VarExpr v -> + -- Tuple.pair SyntaxSeparated <| line <| formatVar v + -- Range left right multiline -> + -- formatRange_0_18 importInfo left right + -- ExplicitList exprs trailing multiline -> + -- Tuple.pair SyntaxSeparated <| + -- formatSequence '[' + -- ',' + -- (Just ']') + -- multiline + -- trailing + -- (syntaxParens SyntaxSeparated << formatExpression importInfo exprs) + -- Binops left ops multiline -> + -- Tuple.pair InfixSeparated <| + -- formatBinops importInfo left ops multiline + -- Lambda patterns bodyComments expr multiline -> + -- Tuple.pair AmbiguousEnd <| + -- case + -- ( multiline + -- , allSingles <| fmap (formatPreCommented << fmap (syntaxParens SpaceSeparated << formatPattern)) patterns + -- , bodyComments == [] + -- , syntaxParens SyntaxSeparated <| formatExpression importInfo expr + -- ) + -- of + -- ( False, Right patterns_, True, SingleLine expr_ ) -> + -- line <| + -- row + -- [ punc "\\" + -- , row <| List.intersperse space patterns_ + -- , space + -- , punc "->" + -- , space + -- , expr_ + -- ] + -- ( _, Right patterns_, _, expr_ ) -> + -- stack1 + -- [ line <| + -- row + -- [ punc "\\" + -- , row (List.intersperse space patterns_) + -- , space + -- , punc "->" + -- ] + -- , indent <| + -- stack1 <| + -- fmap formatComment bodyComments + -- ++ [ expr_ ] + -- ] + -- ( _, Left [], _, _ ) -> + -- pleaseReport "UNEXPECTED LAMBDA" "no patterns" + -- ( _, Left patterns_, _, expr_ ) -> + -- stack1 + -- [ prefix (punc "\\") <| stack1 patterns_ + -- , line <| punc "->" + -- , indent <| + -- stack1 <| + -- fmap formatComment bodyComments + -- ++ [ expr_ ] + -- ] + -- Unary Negative e -> + -- Tuple.pair SyntaxSeparated <| + -- prefix (punc "-") <| + -- syntaxParens SpaceSeparated <| + -- formatExpression importInfo e + -- If if_ elseifs (C elsComments els) -> + -- let + -- opening key cond = + -- case ( key, cond ) of + -- ( SingleLine key_, SingleLine cond_ ) -> + -- line <| + -- row + -- [ key_ + -- , space + -- , cond_ + -- , space + -- , keyword "then" + -- ] + -- _ -> + -- stack1 + -- [ key + -- , cond |> indent + -- , line <| keyword "then" + -- ] + -- formatIf (IfClause cond body) = + -- stack1 + -- [ opening (line <| keyword "if") <| formatCommentedExpression importInfo cond + -- , indent <| formatCommented_ True <| fmap (syntaxParens SyntaxSeparated << formatExpression importInfo) body + -- ] + -- formatElseIf (C ifComments (IfClause cond body)) = + -- let + -- key = + -- case formatPreCommented (C ifComments <| line <| keyword "if") of + -- SingleLine key_ -> + -- line <| row [ keyword "else", space, key_ ] + -- key_ -> + -- stack1 + -- [ line <| keyword "else" + -- , key_ + -- ] + -- in + -- stack1 + -- [ blankLine + -- , opening key <| formatCommentedExpression importInfo cond + -- , indent <| formatCommented_ True <| fmap (syntaxParens SyntaxSeparated << formatExpression importInfo) body + -- ] + -- in + -- Tuple.pair AmbiguousEnd <| + -- formatIf if_ + -- |> andThen (fmap formatElseIf elseifs) + -- |> andThen + -- [ blankLine + -- , line <| keyword "else" + -- , indent <| formatCommented_ True <| fmap (syntaxParens SyntaxSeparated << formatExpression importInfo) (C ( elsComments, [] ) els) + -- ] + -- Let defs bodyComments expr -> + -- let + -- spacer : AST typeRef ctorRef varRef (I.Fix Identity (AST typeRef ctorRef varRef)) LetDeclarationNK -> AST typeRef ctorRef varRef getType LetDeclarationNK -> List Box + -- spacer first _ = + -- case first of + -- LetCommonDeclaration (I.Fix (Identity (Definition _ _ _ _))) -> + -- [ blankLine ] + -- _ -> + -- [] + -- formatDefinition_ def = + -- case def of + -- LetCommonDeclaration (I.Fix (Identity (Definition name args comments expr_))) -> + -- formatDefinition importInfo name args comments expr_ + -- LetCommonDeclaration (I.Fix (Identity (TypeAnnotation name typ))) -> + -- formatTypeAnnotation name typ + -- LetComment comment -> + -- formatComment comment + -- in + -- Tuple.pair AmbiguousEnd <| + -- -- TODO: not tested + -- line (keyword "let") + -- |> andThen + -- (defs + -- |> fmap (extract << I.unFix) + -- |> intersperseMap spacer formatDefinition_ + -- |> map indent + -- ) + -- |> andThen + -- [ line <| keyword "in" + -- , stack1 <| + -- fmap formatComment bodyComments + -- ++ [ syntaxParens SyntaxSeparated <| formatExpression importInfo expr ] + -- ] + -- Case ( subject, multiline ) clauses -> + -- let + -- opening = + -- case + -- ( multiline + -- , formatCommentedExpression importInfo subject + -- ) + -- of + -- ( False, SingleLine subject_ ) -> + -- line <| + -- row + -- [ keyword "case" + -- , space + -- , subject_ + -- , space + -- , keyword "of" + -- ] + -- ( _, subject_ ) -> + -- stack1 + -- [ line <| keyword "case" + -- , indent subject_ + -- , line <| keyword "of" + -- ] + -- clause (CaseBranch prePat postPat preExpr pat expr) = + -- case + -- ( postPat + -- , formatPattern pat + -- |> syntaxParens SyntaxSeparated + -- |> negativeCasePatternWorkaround pat + -- , formatCommentedStack (fmap (syntaxParens SyntaxSeparated << formatPattern) (C ( prePat, postPat ) pat)) + -- |> negativeCasePatternWorkaround pat + -- , formatPreCommentedStack <| fmap (syntaxParens SyntaxSeparated << formatExpression importInfo) (C preExpr expr) + -- ) + -- of + -- ( _, _, SingleLine pat_, body_ ) -> + -- stack1 + -- [ line (row [ pat_, space, keyword "->" ]) + -- , indent body_ + -- ] + -- ( [], SingleLine pat_, _, body_ ) -> + -- stack1 + -- (fmap formatComment prePat + -- ++ [ line (row [ pat_, space, keyword "->" ]) + -- , indent body_ + -- ] + -- ) + -- ( _, _, pat_, body_ ) -> + -- stack1 + -- [ pat_ + -- , line (keyword "->") + -- , indent body_ + -- ] + -- in + -- Tuple.pair AmbiguousEnd <| + -- -- TODO: not tested + -- opening + -- |> andThen + -- (clauses + -- |> fmap (clause << extract << I.unFix) + -- |> List.intersperse blankLine + -- |> map indent + -- ) + -- Tuple exprs multiline -> + -- Tuple.pair SyntaxSeparated <| + -- ElmStructure.group True "(" "," ")" multiline <| + -- map (formatCommentedExpression importInfo) exprs + -- TupleFunction n -> + -- Tuple.pair SyntaxSeparated <| + -- line <| + -- keyword <| + -- "(" + -- ++ List.replicate (n - 1) ',' + -- ++ ")" + -- Access expr field -> + -- Tuple.pair SyntaxSeparated <| + -- formatExpression importInfo expr + -- |> syntaxParens SpaceSeparated + -- -- TODO: does this need a different context than SpaceSeparated? + -- |> addSuffix (row <| [ punc ".", formatLowercaseIdentifier [] field ]) + -- AccessFunction (LowercaseIdentifier field) -> + -- Tuple.pair SyntaxSeparated <| + -- line <| + -- identifier <| + -- "." + -- ++ formatVarName_ field + -- Record base fields trailing multiline -> + -- Tuple.pair SyntaxSeparated <| + -- formatRecordLike + -- (fmap (line << formatLowercaseIdentifier []) base) + -- (fmap (formatPair "=" << mapPair (formatLowercaseIdentifier []) (syntaxParens SyntaxSeparated << formatExpression importInfo)) fields) + -- trailing + -- multiline + -- Parens expr -> + -- case expr of + -- C ( [], [] ) expr_ -> + -- formatExpression importInfo expr_ + -- _ -> + -- Tuple.pair SyntaxSeparated <| + -- formatCommentedExpression importInfo expr + -- |> parens + -- Unit comments -> + -- Tuple.pair SyntaxSeparated <| + -- formatUnit '(' ')' comments + -- GLShader src -> + -- Tuple.pair SyntaxSeparated <| + -- line <| + -- row + -- [ punc "[glsl|" + -- , literal src + -- , punc "|]" + -- ] + Src.Chr char -> + ( SyntaxSeparated, formatLiteral (Chr char) ) + + Src.Str string -> + -- TODO SingleQuotedString + ( SyntaxSeparated, formatLiteral (Str string SingleQuotedString) ) + + Src.Int int -> + -- TODO HexadecimalInt + ( SyntaxSeparated, formatLiteral (IntNum int DecimalInt) ) + + Src.Float float -> + Debug.todo "formatExpression.Float" + + Src.Var Src.LowVar name -> + ( SyntaxSeparated, Box.line (formatVar (VarRef [] name)) ) + + Src.Var Src.CapVar name -> + ( SyntaxSeparated, Box.line (formatVar (TagRef [] name)) ) + + Src.VarQual Src.LowVar prefix name -> + ( SyntaxSeparated, Box.line (formatVar (VarRef (String.split "." prefix) name)) ) + + Src.VarQual Src.CapVar prefix name -> + ( SyntaxSeparated, Box.line (formatVar (TagRef (String.split "." prefix) name)) ) + + Src.List list -> + let + multiline : Bool + multiline = + -- TODO + False + + trailing : Comments + trailing = + [] + + exprs = + List.map (\expr -> ( ( [], [], Nothing ), expr )) list + in + ( SyntaxSeparated + , formatSequence '[' + ',' + (Just ']') + multiline + trailing + (List.map (c2EolMap (syntaxParens SyntaxSeparated << formatExpression importInfo)) exprs) + ) + + Src.Op op -> + Debug.todo "formatExpression.Op" + + Src.Negate expr -> + Debug.todo "formatExpression.Negate" + + Src.Binops ops final -> + -- Binops left ops multiline -> + let + ( left, clauses ) = + List.foldr + (\( currExpr, A.At _ currOp ) ( leftAcc, clausesAcc ) -> + ( currExpr, BinopsClause [] (OpRef currOp) [] leftAcc :: clausesAcc ) + ) + ( final, [] ) + ops + + multiline = + -- TODO + False + in + ( InfixSeparated + , formatBinops importInfo left clauses multiline + ) + + Src.Lambda srcArgs expr -> + -- Lambda patterns bodyComments expr multiline -> + let + patterns = + List.map (\srcArg -> ( [], srcArg )) srcArgs + + bodyComments = + -- TODO + [] + + multiline = + -- TODO + False + in + ( AmbiguousEnd + , case + ( ( multiline + , Box.allSingles <| List.map (formatPreCommented << c1map (syntaxParens SpaceSeparated << formatPattern << A.toValue)) patterns + ) + , ( bodyComments == [] + , syntaxParens SyntaxSeparated <| formatExpression importInfo expr + ) + ) + of + ( ( False, Ok patterns_ ), ( True, Box.SingleLine expr_ ) ) -> + Box.line <| + Box.row + [ Box.punc "\\" + , Box.row <| List.intersperse Box.space patterns_ + , Box.space + , Box.punc "->" + , Box.space + , expr_ + ] + + ( ( _, Ok patterns_ ), ( _, expr_ ) ) -> + Box.stack1 + [ Box.line <| + Box.row + [ Box.punc "\\" + , Box.row (List.intersperse Box.space patterns_) + , Box.space + , Box.punc "->" + ] + , Box.indent <| + Box.stack1 <| + List.map formatComment bodyComments + ++ [ expr_ ] + ] + + ( ( _, Err [] ), ( _, _ ) ) -> + pleaseReport "UNEXPECTED LAMBDA" "no patterns" + + ( ( _, Err patterns_ ), ( _, expr_ ) ) -> + Box.stack1 + [ Box.prefix (Box.punc "\\") <| Box.stack1 patterns_ + , Box.line <| Box.punc "->" + , Box.indent <| + Box.stack1 <| + List.map formatComment bodyComments + ++ [ expr_ ] + ] + ) + + Src.Call func [] -> + -- App left [] _ -> + let + left = + func + in + formatExpression importInfo left + + Src.Call func args_ -> + -- TODO: This might need something stronger than SpaceSeparated? + -- App left args multiline -> + let + left = + func + + args = + List.map (\arg -> ( [], arg )) args_ + + multiline = + -- TODO + ElmStructure.FASplitFirst + in + ( SpaceSeparated + , ElmStructure.application + multiline + (syntaxParens InfixSeparated <| formatExpression importInfo left) + (List.map (formatPreCommentedExpression importInfo SpaceSeparated) args) + ) + + Src.If branches finally -> + Debug.todo "formatExpression.If" + + Src.Let defs expr -> + -- Let defs bodyComments expr -> + let + bodyComments : Comments + bodyComments = + -- TODO + [] + + spacer : A.Located Src.Def -> A.Located Src.Def -> List Box + spacer first _ = + -- case first of + -- LetCommonDeclaration (I.Fix (Identity (Definition _ _ _ _))) -> + -- [ blankLine ] + -- _ -> + -- [] + Debug.todo "spacer" + + formatDefinition_ : A.Located Src.Def -> Box + formatDefinition_ (A.At _ def) = + case def of + -- LetCommonDeclaration (I.Fix (Identity (Definition name args comments expr_))) -> + -- formatDefinition importInfo name args comments expr_ + -- LetCommonDeclaration (I.Fix (Identity (TypeAnnotation name typ))) -> + -- formatTypeAnnotation name typ + -- LetComment comment -> + -- formatComment comment + Src.Define (A.At _ name) srcArgs body maybeType -> + let + comments = + -- TODO + [] + in + formatDefinition importInfo name srcArgs comments body + + Src.Destruct pattern body -> + Debug.todo "formatDefinition_" + in + ( AmbiguousEnd + , -- TODO: not tested + Box.line (Box.keyword "let") + |> Box.andThen + (defs + |> intersperseMap spacer formatDefinition_ + |> List.map Box.indent + ) + |> Box.andThen + [ Box.line (Box.keyword "in") + , Box.stack1 <| + List.map formatComment bodyComments + ++ [ syntaxParens SyntaxSeparated <| formatExpression importInfo expr ] + ] + ) + + Src.Case expr branches -> + Debug.todo "formatExpression.Case" + + Src.Accessor field -> + Debug.todo "formatExpression.Accessor" + + Src.Access record field -> + Debug.todo "formatExpression.Access" + + Src.Update name fields -> + Debug.todo "formatExpression.Update" + + Src.Record fields -> + Debug.todo "formatExpression.Record" + + Src.Unit -> + let + -- TODO + comments = + [] + in + ( SyntaxSeparated + , formatUnit '(' ')' comments + ) + + Src.Tuple a b cs -> + let + multiline = + -- TODO + False + + exprs = + ( [], a, [] ) :: ( [], b, [] ) :: List.map (\c -> ( [], c, [] )) cs + in + Tuple.pair SyntaxSeparated <| + ElmStructure.group True "(" "," ")" multiline <| + List.map (formatCommentedExpression importInfo) exprs + + Src.Shader src tipe -> + Debug.todo "formatExpression.Shader" + + +formatCommentedExpression : ImportInfo -> C2 Src.Expr -> Box +formatCommentedExpression importInfo ( pre, e, post ) = + let + commented_ = + -- TODO + -- case e of + -- Src.Parens (C ( pre__, post__ ) e__) -> + -- ( pre ++ pre__, e__, post__ ++ post ) + -- _ -> + ( pre, e, post ) + in + formatCommented <| c2map (syntaxParens SyntaxSeparated << formatExpression importInfo) commented_ + + +formatPreCommentedExpression : ImportInfo -> SyntaxContext -> C1 Src.Expr -> Box +formatPreCommentedExpression importInfo context ( pre, e ) = + let + ( pre_, e_ ) = + -- TODO + -- case e of + -- Parens (C ( pre__, [] ) e__) -> + -- ( pre ++ pre__, e__ ) + -- _ -> + ( pre, e ) + in + formatCommentedApostrophe pre_ (syntaxParens context <| formatExpression importInfo e_) + + + +-- formatRecordLike : Maybe (C2 before after Box) -> Sequence Box -> Comments -> ForceMultiline -> Box +-- formatRecordLike base_ fields trailing multiline = +-- case ( base_, fields ) of +-- ( Just base, pairs_ ) -> +-- ElmStructure.extensionGroup_ +-- ((\(ForceMultiline b) -> b) multiline) +-- (formatCommented base) +-- (formatSequence '|' +-- ',' +-- Nothing +-- multiline +-- trailing +-- pairs_ +-- ) +-- ( Nothing, pairs_ ) -> +-- formatSequence '{' +-- ',' +-- (Just '}') +-- multiline +-- trailing +-- pairs_ + + +formatSequence : Char -> Char -> Maybe Char -> Bool -> Comments -> List (C2Eol Box) -> Box +formatSequence left delim maybeRight multiline trailing list = + case ( left, maybeRight, list ) of + ( _, _, first :: rest ) -> + let + formatItem : Char -> C2Eol Box -> Box + formatItem delim_ ( ( pre, post, eol ), item ) = + Maybe.unwrap identity (Box.stack_ << Box.stack_ Box.blankLine) (formatComments pre) <| + Box.prefix (Box.row [ Box.punc (String.fromChar delim_), Box.space ]) <| + formatC2Eol <| + ( ( post, [], eol ), item ) + in + ElmStructure.forceableSpaceSepOrStack multiline + (ElmStructure.forceableRowOrStack multiline + (formatItem left first) + (List.map (formatItem delim) rest) + ) + (Maybe.unwrap [] (flip (::) [] << Box.stack_ Box.blankLine) (formatComments trailing) ++ Maybe.toList (Maybe.map (Box.line << Box.punc << String.fromChar) maybeRight)) + + ( _, Just right, [] ) -> + formatUnit left right trailing + + ( _, Nothing, [] ) -> + formatUnit left ' ' trailing + + +mapIsLast : (Bool -> a -> b) -> List a -> List b +mapIsLast f l = + case l of + [] -> + [] + + [ last_ ] -> + [ f True last_ ] + + next :: rest -> + f False next :: mapIsLast f rest + + +type BinopsClause varRef expr + = BinopsClause Comments varRef Comments expr + + +formatBinops : ImportInfo -> Src.Expr -> List (BinopsClause (Ref (List String)) Src.Expr) -> Bool -> Box +formatBinops importInfo left ops multiline = + let + formatPair_ : Bool -> BinopsClause (Ref (List String)) Src.Expr -> ( ( Bool, Comments, Box ), Box ) + formatPair_ isLast (BinopsClause po o pe e) = + let + isLeftPipe = + o == OpRef "<|" + + formatContext = + if isLeftPipe && isLast then + AmbiguousEnd + + else + InfixSeparated + in + ( ( isLeftPipe + , po + , (Box.line << formatInfixVar) o + ) + , formatCommentedApostrophe pe <| syntaxParens formatContext <| formatExpression importInfo e + ) + in + formatBinary + multiline + (syntaxParens InfixSeparated <| formatExpression importInfo left) + (mapIsLast formatPair_ ops) + + + +-- nowhere : A.Position +-- nowhere = +-- A.Position 0 0 +-- noRegion : a -> A.Located a +-- noRegion = +-- A.at nowhere nowhere +-- formatRange_0_18 : +-- ImportInfo (List UppercaseIdentifier) +-- -> C2 before after (ASTNS annf (List UppercaseIdentifier) ExpressionNK) +-- -> C2 before after (ASTNS annf (List UppercaseIdentifier) ExpressionNK) +-- -> ( SyntaxContext, Box ) +-- formatRange_0_18 importInfo left right = +-- case ( left, right ) of +-- ( C ( preLeft, [] ) left_, C ( preRight, [] ) right_ ) -> +-- App +-- (I.Fix <| Identity <| VarExpr <| VarRef [ UppercaseIdentifier "List" ] <| LowercaseIdentifier "range") +-- [ C preLeft <| I.convert (pure << extract) left_ +-- , C preRight <| I.convert (pure << extract) right_ +-- ] +-- (FAJoinFirst JoinAll) +-- |> (I.Fix << pure) +-- |> formatExpression importInfo +-- _ -> +-- App +-- (I.Fix <| Identity <| VarExpr <| VarRef [ UppercaseIdentifier "List" ] <| LowercaseIdentifier "range") +-- [ C [] <| I.Fix <| pure <| Parens <| fmap (I.convert (pure << extract)) left +-- , C [] <| I.Fix <| pure <| Parens <| fmap (I.convert (pure << extract)) right +-- ] +-- (FAJoinFirst JoinAll) +-- |> (I.Fix << pure) +-- |> formatExpression importInfo + + +formatUnit : Char -> Char -> Comments -> Box +formatUnit left right comments = + case ( left, comments ) of + ( _, [] ) -> + Box.line <| Box.punc (String.fromList [ left, right ]) + + ( '{', (Space.LineComment _) :: _ ) -> + surround left right <| Box.prefix Box.space <| Box.stack1 <| List.map formatComment comments + + _ -> + surround left right <| + case Box.allSingles <| List.map formatComment comments of + Ok comments_ -> + Box.line <| Box.row <| List.intersperse Box.space comments_ + + Err comments_ -> + Box.stack1 comments_ + + +formatComments : Comments -> Maybe Box +formatComments comments = + case List.map formatComment comments of + [] -> + Nothing + + first :: rest -> + Just (ElmStructure.spaceSepOrStack first rest) + + +formatCommented_ : Bool -> ( Comments, Box, Comments ) -> Box +formatCommented_ forceMultiline ( pre, inner, post ) = + ElmStructure.forceableSpaceSepOrStack1 forceMultiline <| + List.concat + [ Maybe.toList (formatComments pre) + , [ inner ] + , Maybe.toList (formatComments post) + ] + + +formatCommented : ( Comments, Box, Comments ) -> Box +formatCommented = + formatCommented_ False + + +formatPreCommented : ( Comments, Box ) -> Box +formatPreCommented ( pre, inner ) = + formatCommentedApostrophe pre inner + + +formatCommentedApostrophe : Comments -> Box -> Box +formatCommentedApostrophe pre inner = + formatCommented ( pre, inner, [] ) + + +formatTailCommented : C1 Box -> Box +formatTailCommented ( post, inner ) = + formatCommented ( [], inner, post ) + + +formatC2Eol : C2Eol Box -> Box +formatC2Eol ( ( pre, post, eol ), a ) = + formatCommented ( pre, formatEolCommented ( eol, a ), post ) + + +formatEolCommented : ( Maybe String, Box ) -> Box +formatEolCommented ( post, inner ) = + case ( post, inner ) of + ( Nothing, box ) -> + box + + ( Just eol, Box.SingleLine result ) -> + Box.mustBreak <| Box.row [ result, Box.space, Box.punc "--", Box.literal eol ] + + ( Just eol, box ) -> + Box.stack1 [ box, formatComment <| Space.LineComment eol ] + + + +-- formatCommentedStack : C2 before after Box -> Box +-- formatCommentedStack (C ( pre, post ) inner) = +-- stack1 <| +-- map formatComment pre +-- ++ [ inner ] +-- ++ map formatComment post +-- formatPreCommentedStack : C1 before Box -> Box +-- formatPreCommentedStack (C pre inner) = +-- formatCommentedStack (C ( pre, [] ) inner) + + +formatKeywordCommented : String -> ( List Space.Comment, Box, List Space.Comment ) -> Box +formatKeywordCommented word ( pre, value, post ) = + ElmStructure.spaceSepOrIndented + (formatCommented ( pre, Box.line (Box.keyword word), post )) + [ value ] + + +formatOpenCommentedList : OpenCommentedList Box -> List Box +formatOpenCommentedList (OpenCommentedList rest ( preLst, eol, lst )) = + List.map formatC2Eol rest + ++ [ formatC2Eol ( ( preLst, [], eol ), lst ) ] + + +formatComment : Space.Comment -> Box +formatComment comment = + case comment of + Space.BlockComment c -> + case c of + [] -> + Box.line <| Box.punc "{- -}" + + [ l ] -> + Box.line <| + Box.row + [ Box.punc "{-" + , Box.space + , Box.literal l + , Box.space + , Box.punc "-}" + ] + + ls -> + Box.stack1 + [ Box.prefix + (Box.row [ Box.punc "{-", Box.space ]) + (Box.stack1 <| List.map (Box.line << Box.literal) ls) + , Box.line <| Box.punc "-}" + ] + + Space.LineComment c -> + Box.mustBreak <| Box.row [ Box.punc "--", Box.literal c ] + + Space.CommentTrickOpener -> + Box.mustBreak <| Box.punc "{--}" + + Space.CommentTrickCloser -> + Box.mustBreak <| Box.punc "--}" + + Space.CommentTrickBlock c -> + Box.mustBreak <| Box.row [ Box.punc "{--", Box.literal c, Box.punc "-}" ] + + +type IntRepresentation + = DecimalInt + | HexadecimalInt + + +type FloatRepresentation + = DecimalFloat + | ExponentFloat + + +type StringRepresentation + = SingleQuotedString + | TripleQuotedString + + +type LiteralValue + = IntNum Int IntRepresentation + | FloatNum Float FloatRepresentation + | Chr String + | Str String StringRepresentation + | Boolean Bool + + +formatLiteral : LiteralValue -> Box +formatLiteral lit = + case lit of + IntNum i DecimalInt -> + Box.line <| Box.literal <| String.fromInt i + + IntNum i HexadecimalInt -> + Box.line <| + Box.literal <| + Hex.toString i + + FloatNum f DecimalFloat -> + Box.line <| Box.literal <| String.fromFloat f + + FloatNum f ExponentFloat -> + -- Box.line <| Box.literal <| printf "%e" f + Debug.todo "FloatNum f ExponentFloat" + + Chr c -> + formatString SChar c + + Str s multi -> + formatString (SString multi) s + + Boolean True -> + Box.line <| Box.literal "True" + + Boolean False -> + Box.line <| Box.literal "False" + + +type StringStyle + = SChar + | SString StringRepresentation + + +charIsPrint : Char -> Bool +charIsPrint c = + -- TODO + False + + +charIsSpace : Char -> Bool +charIsSpace c = + let + uc = + Char.toCode c + in + if uc <= 0x0377 then + uc == 32 || uc - 0x09 <= 4 || uc == 0xA0 + + else + c == ' ' + + +formatString : StringStyle -> String -> Box +formatString style s = + let + stringBox quotes escaper = + Box.line <| + Box.row + [ Box.punc quotes + , Box.literal <| escaper <| String.concat <| List.map fix <| String.toList s + , Box.punc quotes + ] + + fix c = + if (style == SString TripleQuotedString) && c == '\n' then + String.fromChar c + + else if c == '\n' then + "\\n" + + else if c == '\t' then + "\\t" + + else if c == '\\' then + "\\\\" + + else if (style == SString SingleQuotedString) && c == '"' then + "\\\"" + + else if (style == SChar) && c == '\'' then + "\\'" + + else if not <| charIsPrint c then + hex c + + else if c == ' ' then + String.fromChar c + + else if charIsSpace c then + hex c + + else + String.fromChar c + + hex char = + -- "\\u{" ++ (printf "%04X" <| Char.toCode char) ++ "}" + Debug.todo "hex char" + + escapeMultiQuote = + let + step : String -> Int -> String -> String + step okay quotes remaining = + case String.toList remaining of + [] -> + String.reverse (String.concat (List.repeat quotes "\"\\") ++ okay) + + next :: rest -> + if next == '"' then + step okay (quotes + 1) (String.fromList rest) + + else if quotes >= 3 then + step (String.cons next (String.concat <| List.repeat quotes "\"\\") ++ okay) 0 (String.fromList rest) + + else if quotes > 0 then + step (String.cons next (String.fromList (List.repeat quotes '"') ++ okay)) 0 (String.fromList rest) + + else + step (String.cons next okay) 0 (String.fromList rest) + in + step "" 0 + in + case style of + SChar -> + stringBox "'" identity + + SString SingleQuotedString -> + stringBox "\"" identity + + SString TripleQuotedString -> + stringBox "\"\"\"" escapeMultiQuote + + +type TypeParensRequired + = {- 0 -} NotRequired + | {- 1 -} ForLambda + | {- 2 -} ForCtor + + +type TypeParensInner + = NotNeeded + | ForFunctionType + | ForTypeConstruction + + +typeParens : TypeParensRequired -> ( TypeParensInner, Box ) -> Box +typeParens outer ( inner, box ) = + if typeParensNeeded outer inner then + parens box + + else + box + + +typeParensNeeded : TypeParensRequired -> TypeParensInner -> Bool +typeParensNeeded outer typeParensInner = + case typeParensInner of + NotNeeded -> + False + + ForTypeConstruction -> + -- outer >= ForCtor + outer == ForCtor + + ForFunctionType -> + -- outer >= ForLambda + outer == ForLambda || outer == ForCtor + + + +-- commaSpace : Line +-- commaSpace = +-- row +-- [ punc "," +-- , space +-- ] +-- formatTypeConstructor : TypeConstructor ( List UppercaseIdentifier, UppercaseIdentifier ) -> Box +-- formatTypeConstructor ctor = +-- case ctor of +-- NamedConstructor ( namespace, name ) -> +-- line <| formatQualifiedUppercaseIdentifier (namespace ++ [ name ]) +-- TupleConstructor n -> +-- line <| keyword <| "(" ++ List.replicate (n - 1) ',' ++ ")" + + +formatType : Src.Type -> ( TypeParensInner, Box ) +formatType atype = + -- case atype of + -- UnitType comments -> + -- Tuple.pair NotNeeded <| + -- formatUnit '(' ')' comments + -- FunctionType first rest (ForceMultiline forceMultiline) -> + -- let + -- formatRight (C ( preOp, postOp, eol ) term) = + -- ElmStructure.forceableSpaceSepOrStack1 + -- False + -- <| + -- concat + -- [ Maybe.maybeToList <| formatComments preOp + -- , [ ElmStructure.prefixOrIndented + -- (line <| punc "->") + -- (formatC2Eol <| + -- (fmap <| typeParens ForLambda << formatType) + -- (C ( postOp, [], eol ) term) + -- ) + -- ] + -- ] + -- in + -- Tuple.pair ForFunctionType <| + -- ElmStructure.forceableSpaceSepOrStack + -- forceMultiline + -- (formatEolCommented (typeParens ForLambda << formatType first)) + -- (formatRight (toCommentedList rest)) + -- TypeVariable var -> + -- Tuple.pair NotNeeded <| + -- line <| + -- identifier <| + -- formatVarName var + -- TypeConstruction ctor args forceMultiline -> + -- let + -- join = + -- case forceMultiline of + -- ForceMultiline True -> + -- FASplitFirst + -- ForceMultiline False -> + -- FAJoinFirst JoinAll + -- in + -- Tuple.pair + -- (if null args then + -- NotNeeded + -- else + -- ForTypeConstruction + -- ) + -- <| + -- ElmStructure.application + -- join + -- (formatTypeConstructor ctor) + -- (fmap (formatPreCommented << fmap (typeParens ForCtor << formatType)) args) + -- TypeParens type_ -> + -- Tuple.pair NotNeeded <| + -- parens <| + -- formatCommented <| + -- fmap (typeParens NotRequired << formatType) type_ + -- TupleType types (ForceMultiline forceMultiline) -> + -- Tuple.pair NotNeeded <| + -- ElmStructure.group True "(" "," ")" forceMultiline (fmap (formatC2Eol << fmap (typeParens NotRequired << formatType)) types) + -- RecordType base fields trailing multiline -> + -- Tuple.pair NotNeeded <| + -- formatRecordLike + -- (fmap (line << formatLowercaseIdentifier []) base) + -- (fmap (formatPair ":" << mapPair (formatLowercaseIdentifier []) (typeParens NotRequired << formatType)) fields) + -- trailing + -- multiline + Debug.todo "formatType" + + +formatVar : Ref (List String) -> Box.Line +formatVar var = + case var of + VarRef namespace name -> + formatLowercaseIdentifier namespace name + + TagRef namespace name -> + case namespace of + [] -> + Box.identifier (formatVarName name) + + _ -> + Box.row + [ formatQualifiedUppercaseIdentifier namespace + , Box.punc "." + , Box.identifier (formatVarName name) + ] + + OpRef name -> + formatSymbolIdentifierInParens name + + +formatSymbolIdentifierInParens : String -> Box.Line +formatSymbolIdentifierInParens name = + Box.identifier <| "(" ++ name ++ ")" + + +formatInfixVar : Ref (List String) -> Box.Line +formatInfixVar var = + case var of + VarRef _ _ -> + Box.row + [ Box.punc "`" + , formatVar var + , Box.punc "`" + ] + + TagRef _ _ -> + Box.row + [ Box.punc "`" + , formatVar var + , Box.punc "`" + ] + + OpRef name -> + Box.identifier name + + +formatLowercaseIdentifier : List String -> String -> Box.Line +formatLowercaseIdentifier namespace name = + case ( namespace, name ) of + ( [], _ ) -> + Box.identifier (formatVarName name) + + _ -> + Box.row + [ formatQualifiedUppercaseIdentifier namespace + , Box.punc "." + , Box.identifier (formatVarName name) + ] + + +formatUppercaseIdentifier : String -> Box.Line +formatUppercaseIdentifier name = + Box.identifier (formatVarName name) + + +formatQualifiedUppercaseIdentifier : List String -> Box.Line +formatQualifiedUppercaseIdentifier names = + Box.identifier <| + String.join "." <| + List.map formatVarName names + + +formatVarName : String -> String +formatVarName name = + String.map + (\x -> + if x == '\'' then + '_' + + else + x + ) + name + + + +-- AST + + +type alias Comments = + List Space.Comment + + +type alias C1 a = + ( Comments, a ) + + +c1map : (a -> b) -> C1 a -> C1 b +c1map f ( comments, a ) = + ( comments, f a ) + + +type alias C2 a = + ( Comments, a, Comments ) + + +c2map : (a -> b) -> C2 a -> C2 b +c2map f ( before, a, after ) = + ( before, f a, after ) + + +sequenceAC2 : List (C2 a) -> C2 (List a) +sequenceAC2 = + List.foldr + (\( before, a, after ) ( beforeAcc, acc, afterAcc ) -> + ( before ++ beforeAcc, a :: acc, after ++ afterAcc ) + ) + ( [], [], [] ) + + +type alias C3 a = + ( ( Comments, Comments, Comments ), a ) + + +type alias C0Eol a = + ( Maybe String, a ) + + +type alias C1Eol a = + ( Comments, Maybe String, a ) + + +type alias C2Eol a = + ( ( Comments, Comments, Maybe String ), a ) + + +c2EolMap : (a -> b) -> C2Eol a -> C2Eol b +c2EolMap f ( ( before, after, eol ), a ) = + ( ( before, after, eol ), f a ) + + +{-| This represents a list of things that have a clear start delimiter but no +clear end delimiter. +There must be at least one item. +Comments can appear before the last item, or around any other item. +An end-of-line comment can also appear after the last item. + +For example: += a += a, b, c + +TODO: this should be replaced with (Sequence a) + +-} +type OpenCommentedList a + = OpenCommentedList (List (C2Eol a)) (C1Eol a) + + +openCommentedListMap : (a -> b) -> OpenCommentedList a -> OpenCommentedList b +openCommentedListMap f (OpenCommentedList rest ( preLst, eolLst, lst )) = + OpenCommentedList + (List.map (\( ( pre, post, eol ), a ) -> ( ( pre, post, eol ), f a )) rest) + ( preLst, eolLst, f lst ) diff --git a/src/Common/Format/Render/ElmStructure.elm b/src/Common/Format/Render/ElmStructure.elm new file mode 100644 index 000000000..11d816647 --- /dev/null +++ b/src/Common/Format/Render/ElmStructure.elm @@ -0,0 +1,391 @@ +module Common.Format.Render.ElmStructure exposing + ( FunctionApplicationMultiline(..) + , Multiline(..) + , application + , definition + , equalsPair + , extensionGroup + , extensionGroup_ + , forceableRowOrStack + , forceableSpaceSepOrIndented + , forceableSpaceSepOrStack + , forceableSpaceSepOrStack1 + , group + , group_ + , prefixOrIndented + , spaceSepOrIndented + , spaceSepOrPrefix + , spaceSepOrStack + ) + +import Common.Format.Box as Box exposing (Box) +import Utils.Crash exposing (crash) + + +{-| Same as `forceableSpaceSepOrStack False` +-} +spaceSepOrStack : Box -> List Box -> Box +spaceSepOrStack = + forceableSpaceSepOrStack False + + +{-| Formats as: + + first rest0 rest1 + + first + + rest0 + + rest1 + +-} +forceableSpaceSepOrStack : Bool -> Box -> List Box -> Box +forceableSpaceSepOrStack forceMultiline first rest = + case + ( forceMultiline, first, Box.allSingles rest ) + of + ( False, Box.SingleLine first_, Ok rest_ ) -> + Box.line <| Box.row <| List.intersperse Box.space (first_ :: rest_) + + _ -> + Box.stack1 (first :: rest) + + +forceableRowOrStack : Bool -> Box -> List Box -> Box +forceableRowOrStack forceMultiline first rest = + case + ( forceMultiline, first, Box.allSingles rest ) + of + ( False, Box.SingleLine first_, Ok rest_ ) -> + Box.line <| Box.row (first_ :: rest_) + + _ -> + Box.stack1 (first :: rest) + + +{-| Same as `forceableSpaceSepOrStack` +-} +forceableSpaceSepOrStack1 : Bool -> List Box -> Box +forceableSpaceSepOrStack1 forceMultiline boxes = + case boxes of + first :: rest -> + forceableSpaceSepOrStack forceMultiline first rest + + _ -> + crash "forceableSpaceSepOrStack1 with empty list" + + +{-| Formats as: + + first rest0 rest1 rest2 + + first + rest0 + rest1 + rest2 + +-} +spaceSepOrIndented : Box -> List Box -> Box +spaceSepOrIndented = + forceableSpaceSepOrIndented False + + +forceableSpaceSepOrIndented : Bool -> Box -> List Box -> Box +forceableSpaceSepOrIndented forceMultiline first rest = + case + ( forceMultiline, first, Box.allSingles rest ) + of + ( False, Box.SingleLine first_, Ok rest_ ) -> + Box.line <| Box.row <| List.intersperse Box.space (first_ :: rest_) + + _ -> + Box.stack1 + (first :: List.map Box.indent rest) + + +{-| Formats as: + + op rest + + op rest1 + rest2 + + opLong + rest + +-} +spaceSepOrPrefix : Box -> Box -> Box +spaceSepOrPrefix op rest = + case ( op, rest ) of + ( Box.SingleLine op_, Box.SingleLine rest_ ) -> + Box.line <| Box.row [ op_, Box.space, rest_ ] + + ( Box.SingleLine op_, _ ) -> + if Box.lineLength 0 op_ < 4 then + Box.prefix (Box.row [ op_, Box.space ]) rest + + else + Box.stack1 [ op, Box.indent rest ] + + _ -> + Box.stack1 [ op, Box.indent rest ] + + +prefixOrIndented : Box -> Box -> Box +prefixOrIndented a b = + case ( a, b ) of + ( Box.SingleLine a_, Box.SingleLine b_ ) -> + Box.line <| Box.row [ a_, Box.space, b_ ] + + ( Box.SingleLine a_, Box.MustBreak b_ ) -> + Box.mustBreak <| Box.row [ a_, Box.space, b_ ] + + _ -> + Box.stack1 [ a, Box.indent b ] + + +{-| Formats as: + + left = + right + left = + right + left = + right + +-} +equalsPair : String -> Bool -> Box -> Box -> Box +equalsPair symbol forceMultiline left right = + case ( forceMultiline, left, right ) of + ( False, Box.SingleLine left_, Box.SingleLine right_ ) -> + Box.line <| + Box.row + [ left_ + , Box.space + , Box.punc symbol + , Box.space + , right_ + ] + + ( _, Box.SingleLine left_, Box.MustBreak right_ ) -> + Box.mustBreak <| + Box.row + [ left_ + , Box.space + , Box.punc symbol + , Box.space + , right_ + ] + + ( _, Box.SingleLine left_, right_ ) -> + Box.stack1 + [ Box.line <| Box.row [ left_, Box.space, Box.punc symbol ] + , Box.indent right_ + ] + + ( _, left_, right_ ) -> + Box.stack1 + [ left_ + , Box.indent <| Box.line <| Box.punc symbol + , Box.indent right_ + ] + + +{-| An equalsPair where the left side is an application +-} +definition : String -> Bool -> Box -> List Box -> Box -> Box +definition symbol forceMultiline first rest = + equalsPair symbol + forceMultiline + (application (FAJoinFirst JoinAll) first rest) + + +{-| Formats as: + + first rest0 rest1 rest2 + + first rest0 + rest1 + rest2 + + first + rest0 + rest1 + rest2 + +-} +application : FunctionApplicationMultiline -> Box -> List Box -> Box +application forceMultiline first args = + case args of + [] -> + first + + arg0 :: rest -> + case + ( ( forceMultiline + , first + ) + , ( arg0 + , Box.allSingles rest + ) + ) + of + ( ( FAJoinFirst JoinAll, Box.SingleLine first_ ), ( Box.SingleLine arg0_, Ok rest_ ) ) -> + (first_ :: arg0_ :: rest_) + |> List.intersperse Box.space + |> Box.row + |> Box.line + + ( ( FAJoinFirst _, Box.SingleLine first_ ), ( Box.SingleLine arg0_, _ ) ) -> + Box.stack1 <| + Box.line (Box.row [ first_, Box.space, arg0_ ]) + :: List.map Box.indent rest + + _ -> + Box.stack1 <| + first + :: List.map Box.indent (arg0 :: rest) + + +{-| `group True '<' ';' '>'` formats as: + + <> + + < child0 > + + < child0; child1; child2 > + + < child0 + ; child1 + ; child2 + > + +-} +group : Bool -> String -> String -> String -> Bool -> List Box -> Box +group innerSpaces left sep right forceMultiline children = + group_ innerSpaces left sep [] right forceMultiline children + + +group_ : Bool -> String -> String -> List Box -> String -> Bool -> List Box -> Box +group_ innerSpaces left sep extraFooter right forceMultiline children = + case ( forceMultiline, Box.allSingles children, Box.allSingles extraFooter ) of + ( _, Ok [], Ok efs ) -> + Box.line <| Box.row <| List.concat [ [ Box.punc left ], efs, [ Box.punc right ] ] + + ( False, Ok ls, Ok efs ) -> + Box.line <| + Box.row <| + List.concat + [ if innerSpaces then + [ Box.punc left, Box.space ] + + else + [ Box.punc left ] + , List.intersperse (Box.row [ Box.punc sep, Box.space ]) (ls ++ efs) + , if innerSpaces then + [ Box.space, Box.punc right ] + + else + [ Box.punc right ] + ] + + _ -> + case children of + [] -> + -- TODO: might lose extraFooter in this case, but can that ever happen? + Box.line <| Box.row [ Box.punc left, Box.punc right ] + + first :: rest -> + Box.stack1 <| + Box.prefix (Box.row [ Box.punc left, Box.space ]) first + :: List.map (Box.prefix <| Box.row [ Box.punc sep, Box.space ]) rest + ++ extraFooter + ++ [ Box.line <| Box.punc right ] + + +{-| Formats as: + + { base | first } + + { base | first, rest0, rest1 } + + { base + | first + , rest0 + , rest1 + } + +-} +extensionGroup : Bool -> Box -> Box -> List Box -> Box +extensionGroup multiline base first rest = + case + ( multiline + , Box.isLine base + , Box.allSingles (first :: rest) + ) + of + ( False, Ok base_, Ok fields_ ) -> + Box.line <| + Box.row + [ Box.punc "{" + , Box.space + , base_ + , Box.space + , Box.punc "|" + , Box.space + , Box.row (List.intersperse (Box.row [ Box.punc ",", Box.space ]) fields_) + , Box.space + , Box.punc "}" + ] + + _ -> + Box.stack1 + [ Box.prefix (Box.row [ Box.punc "{", Box.space ]) base + , Box.stack1 + (Box.prefix (Box.row [ Box.punc "|", Box.space ]) first + :: List.map (Box.prefix (Box.row [ Box.punc ",", Box.space ])) rest + ) + |> Box.indent + , Box.line <| Box.punc "}" + ] + + +extensionGroup_ : Bool -> Box -> Box -> Box +extensionGroup_ multiline base fields = + case + ( multiline + , base + , fields + ) + of + ( False, Box.SingleLine base_, Box.SingleLine fields_ ) -> + Box.line <| + Box.row <| + List.intersperse Box.space + [ Box.punc "{" + , base_ + , fields_ + , Box.punc "}" + ] + + _ -> + Box.stack1 + [ Box.prefix (Box.row [ Box.punc "{", Box.space ]) base + , Box.indent fields + , Box.line <| Box.punc "}" + ] + + + +-- FROM `AST.V0_16` + + +type Multiline + = JoinAll + | SplitAll + + +type FunctionApplicationMultiline + = FASplitFirst + | FAJoinFirst Multiline diff --git a/src/Common/Format/Render/Markdown.elm b/src/Common/Format/Render/Markdown.elm new file mode 100644 index 000000000..fbda456ec --- /dev/null +++ b/src/Common/Format/Render/Markdown.elm @@ -0,0 +1,493 @@ +module Common.Format.Render.Markdown exposing (..) + +import Data.Map exposing (Dict) +import Maybe.Extra as Maybe +import Url +import Utils.Main as Utils + + +formatMarkdown : (String -> Maybe String) -> Blocks -> String +formatMarkdown formatCode blocks = + let + needsInitialBlanks = + case blocks of + (Para inlines) :: _ -> + case inlines of + (Str a) :: (Str b) :: _ -> + if (a == "@") && (b == "docs") then + True + + else + False + + _ -> + False + + [] -> + False + + _ -> + True + + needsTrailingBlanks = + case blocks of + [] -> + False + + _ :: [] -> + needsInitialBlanks + + _ -> + True + in + formatMarkdown_ formatCode False needsInitialBlanks needsTrailingBlanks blocks + + +mapWithPrev : (Maybe a -> a -> b) -> List a -> List b +mapWithPrev f list = + case list of + [] -> + [] + + first :: rest -> + f Nothing first :: List.map2 (\prev next -> f (Just prev) next) (first :: rest) rest + + +formatMarkdown_ : (String -> Maybe String) -> Bool -> Bool -> Bool -> List Block -> String +formatMarkdown_ formatCode isListItem needsInitialBlanks needsTrailingBlanks blocks = + let + intersperse = + case ( isListItem, blocks ) of + ( True, [ Para _, List _ _ _ ] ) -> + identity + + _ -> + List.intersperse "\n" + + contextFor prev = + case prev of + Just (List _ _ _) -> + AfterIndentedList + + _ -> + Normal + in + (if needsInitialBlanks then + "\n\n" + + else + "" + ) + ++ (String.concat <| intersperse <| mapWithPrev (\prev -> formatMardownBlock formatCode (contextFor prev)) blocks) + ++ (if needsTrailingBlanks then + "\n" + + else + "" + ) + + +type Context + = Normal + | AfterIndentedList + + +formatMardownBlock : (String -> Maybe String) -> Context -> Block -> String +formatMardownBlock formatCode context block = + case block of + ElmDocs terms -> + (String.join "\n" <| List.map ((++) "@docs " << String.join ", ") terms) ++ "\n" + + Para inlines -> + (String.concat <| List.map (formatMarkdownInline True) <| inlines) ++ "\n" + + Header level inlines -> + "\n" ++ String.repeat level "#" ++ " " ++ (String.concat <| List.map (formatMarkdownInline True) inlines) ++ "\n" + + Blockquote blocks -> + formatMarkdown_ formatCode False False False blocks + |> prefix_ "> " "> " + + List tight (Bullet _) items -> + String.concat <| + (if tight then + identity + + else + List.intersperse "\n" + ) + <| + List.map (prefix_ " - " " " << formatMarkdown_ formatCode True False False) items + + List tight (Numbered _ _) items -> + String.concat <| + (if tight then + identity + + else + List.intersperse "\n" + ) + <| + List.map (formatListItem formatCode) <| + List.indexedMap Tuple.pair items + + CodeBlock (CodeAttr { codeLang }) code -> + let + isElm = + codeLang == "elm" || codeLang == "" + + formatted = + Maybe.withDefault (ensureNewline code) <| + if isElm then + formatCode code + + else + Nothing + + ensureNewline text = + if String.endsWith "\n" text then + text + + else + text ++ "\n" + + canIndent = + case context of + Normal -> + True + + AfterIndentedList -> + False + in + if isElm && canIndent then + Utils.unlines <| List.map ((++) " ") <| String.lines <| formatted + + else + "```" ++ codeLang ++ "\n" ++ formatted ++ "```\n" + + HtmlBlock text -> + text ++ "\n" + + HRule -> + "---\n" + + ReferencesBlock refs -> + String.concat <| List.map formatRef refs + + +formatListItem : (String -> Maybe String) -> ( Int, Blocks ) -> String +formatListItem formatCode ( i, item ) = + let + pref = + if i < 10 then + String.fromInt i ++ ". " + + else + String.fromInt i ++ ". " + in + prefix_ pref " " <| formatMarkdown_ formatCode True False False item + + +formatRef : ( String, String, String ) -> String +formatRef ( label, url, title ) = + "[" + ++ label + ++ "]: " + ++ url + ++ (if title == "" then + "" + + else + " \"" ++ title ++ "\"" + ) + ++ "\n" + + +prefix_ : String -> String -> String -> String +prefix_ preFirst preRest = + Utils.unlines << prefix preFirst preRest << String.lines + + +prefix : String -> String -> List String -> List String +prefix preFirst preRest list = + case list of + [] -> + [] + + first :: rest -> + (preFirst ++ first) :: List.map ((++) preRest) rest + + +formatMarkdownInline : Bool -> Inline -> String +formatMarkdownInline fixSpecialChars inline = + let + fix c = + case c of + '\\' -> + "\\\\" + + -- TODO: only at the beginning of words + '`' -> + "\\`" + + '_' -> + "\\_" + + '*' -> + "\\*" + + -- TODO: {} curly braces (when?) + -- TODO: [] square brackets (when?) + -- TODO: () parentheses (when?) + -- TODO: # hash mark (only at the beginning of lines, and within header lines?) + -- TODO: - minus sign (hyphen) (only at the beginning of lines?) + -- TODO: + plus sign (when?) + -- TODO: . dot (when?) + -- TODO: ! exclamation mark (when?) + _ -> + String.fromChar c + in + case inline of + Str text -> + (if fixSpecialChars then + String.concat << List.map fix << String.toList + + else + identity + ) + text + + Space -> + " " + + SoftBreak -> + "\n" + + LineBreak -> + "\n" + + Emph inlines -> + "_" ++ (String.concat <| List.map (formatMarkdownInline True) <| inlines) ++ "_" + + -- TODO: escaping + Strong inlines -> + "**" ++ (String.concat <| List.map (formatMarkdownInline True) <| inlines) ++ "**" + + -- TODO: escaping + Code text -> + case longestSpanOf '`' text of + NoSpan -> + "`" ++ text ++ "`" + + Span n -> + let + delimiter = + String.repeat (n + 1) "`" + in + delimiter ++ " " ++ text ++ " " ++ delimiter + + Link inlines (Url url) title -> + let + text = + String.concat <| List.map (formatMarkdownInline fixSpecialChars) inlines + + textRaw = + String.concat <| List.map (formatMarkdownInline False) inlines + + isValidAutolink = + Url.fromString >> Maybe.isJust + in + if textRaw == url && title == "" && isValidAutolink url then + if fixSpecialChars then + "<" ++ url ++ ">" + + else + url + + else + "[" + ++ text + ++ "](" + ++ url + ++ (if title == "" then + "" + + else + " \"" ++ title ++ "\"" + ) + ++ ")" + + Link inlines (Ref ref) _ -> + let + text = + String.concat <| List.map (formatMarkdownInline fixSpecialChars) inlines + in + if text == ref || ref == "" then + "[" ++ text ++ "]" + + else + "[" ++ text ++ "][" ++ ref ++ "]" + + Image inlines url title -> + "![" + ++ (String.concat <| List.map (formatMarkdownInline fixSpecialChars) inlines) + ++ "](" + ++ url + ++ (if title == "" then + "" + + else + " \"" ++ title ++ "\"" + ) + ++ ")" + + Entity text -> + text + + RawHtml text -> + text + + + +-- TEXT EXTRA + + +type LongestSpanResult + = NoSpan + | Span Int + + + +{- >= 1 -} + + +longestSpanOf : Char -> String -> LongestSpanResult +longestSpanOf char input = + let + step c ( currentSpan, longest ) = + if c == char then + ( Just (1 + Maybe.withDefault 0 currentSpan) + , longest + ) + + else + ( -- clear the current span + Nothing + , -- and update the longest + endCurrentSpan ( currentSpan, longest ) + ) + + endCurrentSpan acc = + case acc of + ( Nothing, longest ) -> + longest + + ( Just current, longest ) -> + max current longest + in + case String.foldl step ( Nothing, 0 ) input |> endCurrentSpan of + 0 -> + NoSpan + + positive -> + Span positive + + + +-- TYPES + + +{-| Structured representation of a document. The 'Options' affect +how the document is rendered by `toHtml`. +-} +type Doc + = Doc Options Blocks + + +{-| Block-level elements. +-} +type Block + = Para Inlines + | Header Int Inlines + | Blockquote Blocks + | List Bool ListType (List Blocks) + | CodeBlock CodeAttr String + | HtmlBlock String + | HRule + | ReferencesBlock (List ( String, String, String )) + | ElmDocs (List (List String)) + + +{-| Attributes for fenced code blocks. 'codeLang' is the +first word of the attribute line, 'codeInfo' is the rest. +-} +type CodeAttr + = CodeAttr + { codeLang : String + , codeInfo : String + } + + +type ListType + = Bullet Char + | Numbered NumWrapper Int + + +type NumWrapper + = PeriodFollowing + | ParenFollowing + + +{-| Simple representation of HTML tag. +-} +type HtmlTagType + = Opening String + | Closing String + | SelfClosing String + + +{-| We operate with sequences instead of lists, because +they allow more efficient appending on to the end. +-} +type alias Blocks = + List Block + + +{-| Inline elements. +-} +type Inline + = Str String + | Space + | SoftBreak + | LineBreak + | Emph Inlines + | Strong Inlines + | Code String + | Link Inlines LinkTarget {- URL -} String {- title -} + | Image Inlines String {- URL -} String {- title -} + | Entity String + | RawHtml String + + +type LinkTarget + = Url String + | Ref String + + +type alias Inlines = + List Inline + + +type alias ReferenceMap = + Dict String String ( String, String ) + + +{-| Rendering and parsing options. +-} +type Options + = Options + { sanitize : Bool -- ^ Sanitize raw HTML, link/image attributes + , allowRawHtml : Bool -- ^ Allow raw HTML (if false it gets escaped) + , preserveHardBreaks : Bool -- ^ Preserve hard line breaks in the source + , debug : Bool -- ^ Print container structure for debugging + } diff --git a/src/Compiler/AST/Source.elm b/src/Compiler/AST/Source.elm index 585d716d6..788b1c75a 100644 --- a/src/Compiler/AST/Source.elm +++ b/src/Compiler/AST/Source.elm @@ -188,7 +188,7 @@ type Manager type Docs - = NoDocs A.Region + = NoDocs A.Region (List ( Name, Comment )) | YesDocs Comment (List ( Name, Comment )) @@ -390,10 +390,11 @@ exposingDecoder = docsEncoder : Docs -> BE.Encoder docsEncoder docs = case docs of - NoDocs region -> + NoDocs region comments -> BE.sequence [ BE.unsignedInt8 0 , A.regionEncoder region + , BE.list (BE.jsonPair BE.string commentEncoder) comments ] YesDocs overview comments -> @@ -411,7 +412,9 @@ docsDecoder = (\idx -> case idx of 0 -> - BD.map NoDocs A.regionDecoder + BD.map2 NoDocs + A.regionDecoder + (BD.list (BD.jsonPair BD.string commentDecoder)) 1 -> BD.map2 YesDocs diff --git a/src/Compiler/Elm/Docs.elm b/src/Compiler/Elm/Docs.elm index f4c976343..225f464e9 100644 --- a/src/Compiler/Elm/Docs.elm +++ b/src/Compiler/Elm/Docs.elm @@ -18,6 +18,7 @@ module Compiler.Elm.Docs exposing , jsonEncoder , jsonModuleDecoder , jsonModuleEncoder + , parseOverview ) import Basics.Extra exposing (flip) @@ -328,7 +329,7 @@ fromModule ((Can.Module _ exports docs _ _ _ _ _) as modul) = Can.Export exportDict -> case docs of - Src.NoDocs region -> + Src.NoDocs region _ -> Err (E.NoDocs region) Src.YesDocs overview comments -> @@ -367,7 +368,14 @@ chompOverviewHelp names = (\isDocs -> if isDocs then Space.chomp E.Space - |> P.bind (\_ -> chompDocs names) + |> P.bind + (\c104 -> + let + _ = + Debug.log "c104" c104 + in + chompDocs names + ) |> P.fmap P.Loop else @@ -393,7 +401,11 @@ chompDocsHelp names = (\name -> Space.chomp E.Space |> P.bind - (\_ -> + (\c105 -> + let + _ = + Debug.log "c105" c105 + in P.oneOfWithFallback [ P.getPosition |> P.bind @@ -405,7 +417,14 @@ chompDocsHelp names = |> P.bind (\_ -> Space.chomp E.Space - |> P.fmap (\_ -> P.Loop (name :: names)) + |> P.fmap + (\c106 -> + let + _ = + Debug.log "c106" c106 + in + P.Loop (name :: names) + ) ) ) ) diff --git a/src/Compiler/Elm/Kernel.elm b/src/Compiler/Elm/Kernel.elm index 75e363559..e8a0ada28 100644 --- a/src/Compiler/Elm/Kernel.elm +++ b/src/Compiler/Elm/Kernel.elm @@ -108,7 +108,14 @@ parser : Pkg.Name -> Foreigns -> P.Parser () Content parser pkg foreigns = P.word2 '/' '*' toError |> P.bind (\_ -> Space.chomp ignoreError) - |> P.bind (\_ -> Space.checkFreshLine toError) + |> P.bind + (\c107 -> + let + _ = + Debug.log "c107" c107 + in + Space.checkFreshLine toError + ) |> P.bind (\_ -> P.specialize ignoreError (Module.chompImports [])) |> P.bind (\imports -> diff --git a/src/Compiler/Parse/Declaration.elm b/src/Compiler/Parse/Declaration.elm index 164a85db2..180ff6361 100644 --- a/src/Compiler/Parse/Declaration.elm +++ b/src/Compiler/Parse/Declaration.elm @@ -26,7 +26,7 @@ import Compiler.Reporting.Error.Syntax as E type Decl - = Value (Maybe Src.Comment) (A.Located Src.Value) + = Value (Maybe Src.Comment) (List Space.Comment) (A.Located Src.Value) | Union (Maybe Src.Comment) (A.Located Src.Union) | Alias (Maybe Src.Comment) (A.Located Src.Alias) | Port (Maybe Src.Comment) Src.Port @@ -36,14 +36,14 @@ declaration : SyntaxVersion -> Space.Parser E.Decl Decl declaration syntaxVersion = chompDocComment |> P.bind - (\maybeDocs -> + (\( comments, maybeDocs ) -> P.getPosition |> P.bind (\start -> P.oneOf E.DeclStart [ typeDecl maybeDocs start , portDecl maybeDocs - , valueDecl syntaxVersion maybeDocs start + , valueDecl syntaxVersion maybeDocs comments start ] ) ) @@ -53,26 +53,33 @@ declaration syntaxVersion = -- DOC COMMENT -chompDocComment : P.Parser E.Decl (Maybe Src.Comment) +chompDocComment : P.Parser E.Decl ( List Space.Comment, Maybe Src.Comment ) chompDocComment = P.oneOfWithFallback [ Space.docComment E.DeclStart E.DeclSpace |> P.bind (\docComment -> Space.chomp E.DeclSpace - |> P.bind (\_ -> Space.checkFreshLine E.DeclFreshLineAfterDocComment) - |> P.fmap (\_ -> Just docComment) + |> P.bind + (\comments -> + let + _ = + Debug.log "c108" comments + in + Space.checkFreshLine E.DeclFreshLineAfterDocComment + |> P.fmap (\_ -> ( comments, Just docComment )) + ) ) ] - Nothing + ( [], Nothing ) -- DEFINITION and ANNOTATION -valueDecl : SyntaxVersion -> Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl -valueDecl syntaxVersion maybeDocs start = +valueDecl : SyntaxVersion -> Maybe Src.Comment -> List Space.Comment -> A.Position -> Space.Parser E.Decl Decl +valueDecl syntaxVersion maybeDocs comments start = Var.lower E.DeclStart |> P.bind (\name -> @@ -82,11 +89,22 @@ valueDecl syntaxVersion maybeDocs start = P.specialize (E.DeclDef name) <| (Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals |> P.bind - (\_ -> + (\c1 -> + let + _ = + Debug.log "c1" c1 + in P.oneOf E.DeclDefEquals [ P.word1 ':' E.DeclDefEquals |> P.bind (\_ -> Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType) - |> P.bind (\_ -> P.specialize E.DeclDefType Type.expression) + |> P.bind + (\c2 -> + let + _ = + Debug.log "c2" c2 + in + P.specialize E.DeclDefType Type.expression + ) |> P.bind (\( tipe, _ ) -> Space.checkFreshLine E.DeclDefNameRepeat @@ -94,10 +112,17 @@ valueDecl syntaxVersion maybeDocs start = |> P.bind (\defName -> Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals - |> P.bind (\_ -> chompDefArgsAndBody syntaxVersion maybeDocs start defName (Just tipe) []) + |> P.bind + (\c3 -> + let + _ = + Debug.log "c3" c3 + in + chompDefArgsAndBody syntaxVersion maybeDocs comments start defName (Just tipe) [] + ) ) ) - , chompDefArgsAndBody syntaxVersion maybeDocs start (A.at start end name) Nothing [] + , chompDefArgsAndBody syntaxVersion maybeDocs comments start (A.at start end name) Nothing [] ] ) ) @@ -105,18 +130,32 @@ valueDecl syntaxVersion maybeDocs start = ) -chompDefArgsAndBody : SyntaxVersion -> Maybe Src.Comment -> A.Position -> A.Located Name -> Maybe Src.Type -> List Src.Pattern -> Space.Parser E.DeclDef Decl -chompDefArgsAndBody syntaxVersion maybeDocs start name tipe revArgs = +chompDefArgsAndBody : SyntaxVersion -> Maybe Src.Comment -> List Space.Comment -> A.Position -> A.Located Name -> Maybe Src.Type -> List Src.Pattern -> Space.Parser E.DeclDef Decl +chompDefArgsAndBody syntaxVersion maybeDocs comments start name tipe revArgs = P.oneOf E.DeclDefEquals [ P.specialize E.DeclDefArg (Pattern.term syntaxVersion) |> P.bind (\arg -> Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals - |> P.bind (\_ -> chompDefArgsAndBody syntaxVersion maybeDocs start name tipe (arg :: revArgs)) + |> P.bind + (\c4 -> + let + _ = + Debug.log "c4" c4 + in + chompDefArgsAndBody syntaxVersion maybeDocs comments start name tipe (arg :: revArgs) + ) ) , P.word1 '=' E.DeclDefEquals |> P.bind (\_ -> Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentBody) - |> P.bind (\_ -> P.specialize E.DeclDefBody (Expr.expression syntaxVersion)) + |> P.bind + (\c5 -> + let + _ = + Debug.log "c5" c5 + in + P.specialize E.DeclDefBody (Expr.expression syntaxVersion) + ) |> P.fmap (\( body, end ) -> let @@ -128,7 +167,7 @@ chompDefArgsAndBody syntaxVersion maybeDocs start name tipe revArgs = avalue = A.at start end value in - ( Value maybeDocs avalue, end ) + ( Value maybeDocs comments avalue, end ) ) ] @@ -172,11 +211,22 @@ typeDecl maybeDocs start = P.inContext E.DeclType (Keyword.type_ E.DeclStart) <| (Space.chompAndCheckIndent E.DT_Space E.DT_IndentName |> P.bind - (\_ -> + (\c6 -> + let + _ = + Debug.log "c6" c6 + in P.oneOf E.DT_Name [ P.inContext E.DT_Alias (Keyword.alias_ E.DT_Name) <| (Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals - |> P.bind (\_ -> chompAliasNameToEquals) + |> P.bind + (\c7 -> + let + _ = + Debug.log "c7" c7 + in + chompAliasNameToEquals + ) |> P.bind (\( name, args ) -> P.specialize E.AliasBody Type.expression @@ -226,7 +276,14 @@ chompAliasNameToEquals = |> P.bind (\name -> Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals - |> P.bind (\_ -> chompAliasNameToEqualsHelp name []) + |> P.bind + (\c8 -> + let + _ = + Debug.log "c8" c8 + in + chompAliasNameToEqualsHelp name [] + ) ) @@ -237,11 +294,25 @@ chompAliasNameToEqualsHelp name args = |> P.bind (\arg -> Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals - |> P.bind (\_ -> chompAliasNameToEqualsHelp name (arg :: args)) + |> P.bind + (\c9 -> + let + _ = + Debug.log "c9" c9 + in + chompAliasNameToEqualsHelp name (arg :: args) + ) ) , P.word1 '=' E.AliasEquals |> P.bind (\_ -> Space.chompAndCheckIndent E.AliasSpace E.AliasIndentBody) - |> P.fmap (\_ -> ( name, List.reverse args )) + |> P.fmap + (\c10 -> + let + _ = + Debug.log "c10" c10 + in + ( name, List.reverse args ) + ) ] @@ -255,7 +326,14 @@ chompCustomNameToEquals = |> P.bind (\name -> Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals - |> P.bind (\_ -> chompCustomNameToEqualsHelp name []) + |> P.bind + (\c11 -> + let + _ = + Debug.log "c11" c11 + in + chompCustomNameToEqualsHelp name [] + ) ) @@ -266,11 +344,25 @@ chompCustomNameToEqualsHelp name args = |> P.bind (\arg -> Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals - |> P.bind (\_ -> chompCustomNameToEqualsHelp name (arg :: args)) + |> P.bind + (\c12 -> + let + _ = + Debug.log "c12" c12 + in + chompCustomNameToEqualsHelp name (arg :: args) + ) ) , P.word1 '=' E.CT_Equals |> P.bind (\_ -> Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterEquals) - |> P.fmap (\_ -> ( name, List.reverse args )) + |> P.fmap + (\c13 -> + let + _ = + Debug.log "c13" c13 + in + ( name, List.reverse args ) + ) ] @@ -280,7 +372,14 @@ chompVariants variants end = [ Space.checkIndent end E.CT_IndentBar |> P.bind (\_ -> P.word1 '|' E.CT_Bar) |> P.bind (\_ -> Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterBar) - |> P.bind (\_ -> Type.variant) + |> P.bind + (\c14 -> + let + _ = + Debug.log "c14" c14 + in + Type.variant + ) |> P.bind (\( variant, newEnd ) -> chompVariants (variant :: variants) newEnd) ] ( List.reverse variants, end ) @@ -294,14 +393,32 @@ portDecl : Maybe Src.Comment -> Space.Parser E.Decl Decl portDecl maybeDocs = P.inContext E.Port (Keyword.port_ E.DeclStart) <| (Space.chompAndCheckIndent E.PortSpace E.PortIndentName - |> P.bind (\_ -> P.addLocation (Var.lower E.PortName)) + |> P.bind + (\c15 -> + let + _ = + Debug.log "c15" c15 + in + P.addLocation (Var.lower E.PortName) + ) |> P.bind (\name -> Space.chompAndCheckIndent E.PortSpace E.PortIndentColon - |> P.bind (\_ -> P.word1 ':' E.PortColon) + |> P.bind + (\c16 -> + let + _ = + Debug.log "c16" c16 + in + P.word1 ':' E.PortColon + ) |> P.bind (\_ -> Space.chompAndCheckIndent E.PortSpace E.PortIndentType) |> P.bind - (\_ -> + (\c17 -> + let + _ = + Debug.log "c17" c17 + in P.specialize E.PortType Type.expression |> P.fmap (\( tipe, end ) -> @@ -337,7 +454,11 @@ infix_ = Keyword.infix_ err |> P.bind (\_ -> Space.chompAndCheckIndent err_ err) |> P.bind - (\_ -> + (\c18 -> + let + _ = + Debug.log "c18" c18 + in P.oneOf err [ Keyword.left_ err |> P.fmap (\_ -> Binop.Left) , Keyword.right_ err |> P.fmap (\_ -> Binop.Right) @@ -347,26 +468,61 @@ infix_ = |> P.bind (\associativity -> Space.chompAndCheckIndent err_ err - |> P.bind (\_ -> Number.precedence err) + |> P.bind + (\c19 -> + let + _ = + Debug.log "c19" c19 + in + Number.precedence err + ) |> P.bind (\precedence -> Space.chompAndCheckIndent err_ err - |> P.bind (\_ -> P.word1 '(' err) + |> P.bind + (\c20 -> + let + _ = + Debug.log "c20" c20 + in + P.word1 '(' err + ) |> P.bind (\_ -> Symbol.operator err err_) |> P.bind (\op -> P.word1 ')' err |> P.bind (\_ -> Space.chompAndCheckIndent err_ err) - |> P.bind (\_ -> P.word1 '=' err) + |> P.bind + (\c21 -> + let + _ = + Debug.log "c21" c21 + in + P.word1 '=' err + ) |> P.bind (\_ -> Space.chompAndCheckIndent err_ err) - |> P.bind (\_ -> Var.lower err) + |> P.bind + (\c22 -> + let + _ = + Debug.log "c22" c22 + in + Var.lower err + ) |> P.bind (\name -> P.getPosition |> P.bind (\end -> Space.chomp err_ - |> P.bind (\_ -> Space.checkFreshLine err) + |> P.bind + (\c109 -> + let + _ = + Debug.log "c109" c109 + in + Space.checkFreshLine err + ) |> P.fmap (\_ -> A.at start end (Src.Infix op associativity precedence name)) ) ) diff --git a/src/Compiler/Parse/Expression.elm b/src/Compiler/Parse/Expression.elm index c9ba6d39f..bc557075f 100644 --- a/src/Compiler/Parse/Expression.elm +++ b/src/Compiler/Parse/Expression.elm @@ -114,7 +114,11 @@ list syntaxVersion start = P.inContext E.List (P.word1 '[' E.Start) <| (Space.chompAndCheckIndent E.ListSpace E.ListIndentOpen |> P.bind - (\_ -> + (\c23 -> + let + _ = + Debug.log "c23" c23 + in P.oneOf E.ListOpen [ P.specialize E.ListExpr (expression syntaxVersion) |> P.bind @@ -134,7 +138,14 @@ chompListEnd syntaxVersion start entries = P.oneOf E.ListEnd [ P.word1 ',' E.ListEnd |> P.bind (\_ -> Space.chompAndCheckIndent E.ListSpace E.ListIndentExpr) - |> P.bind (\_ -> P.specialize E.ListExpr (expression syntaxVersion)) + |> P.bind + (\c24 -> + let + _ = + Debug.log "c24" c24 + in + P.specialize E.ListExpr (expression syntaxVersion) + ) |> P.bind (\( entry, end ) -> Space.checkIndent end E.ListIndentEnd @@ -158,7 +169,11 @@ tuple syntaxVersion ((A.Position row col) as start) = (\before -> Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr1 |> P.bind - (\_ -> + (\c25 -> + let + _ = + Debug.log "c25" c25 + in P.getPosition |> P.bind (\after -> @@ -185,8 +200,11 @@ tuple syntaxVersion ((A.Position row col) as start) = (\((A.At (A.Region _ end) _) as negatedExpr) -> Space.chomp E.Space |> P.bind - (\_ -> + (\c110 -> let + _ = + Debug.log "c110" c110 + exprStart : A.Position exprStart = A.Position row (col + 2) @@ -241,7 +259,11 @@ chompTupleEnd syntaxVersion start firstExpr revExprs = (\_ -> Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExprN |> P.bind - (\_ -> + (\c26 -> + let + _ = + Debug.log "c26" c26 + in P.specialize E.TupleExpr (expression syntaxVersion) |> P.bind (\( entry, end ) -> @@ -274,7 +296,11 @@ record syntaxVersion start = P.inContext E.Record (P.word1 '{' E.Start) <| (Space.chompAndCheckIndent E.RecordSpace E.RecordIndentOpen |> P.bind - (\_ -> + (\c27 -> + let + _ = + Debug.log "c27" c27 + in P.oneOf E.RecordOpen [ P.word1 '}' E.RecordOpen |> P.bind (\_ -> P.addEnd start (Src.Record [])) @@ -283,16 +309,34 @@ record syntaxVersion start = (\((A.At starterPosition starterName) as starter) -> Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals |> P.bind - (\_ -> + (\c28 -> + let + _ = + Debug.log "c28" c28 + in P.oneOf E.RecordEquals [ P.word1 '|' E.RecordEquals |> P.bind (\_ -> Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField) - |> P.bind (\_ -> chompField syntaxVersion) + |> P.bind + (\c29 -> + let + _ = + Debug.log "c29" c29 + in + chompField syntaxVersion + ) |> P.bind (\firstField -> chompFields syntaxVersion [ firstField ]) |> P.bind (\fields -> P.addEnd start (Src.Update (A.At starterPosition (Src.Var Src.LowVar starterName)) fields)) , P.word1 '=' E.RecordEquals |> P.bind (\_ -> Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr) - |> P.bind (\_ -> P.specialize E.RecordExpr (expression syntaxVersion)) + |> P.bind + (\c30 -> + let + _ = + Debug.log "c30" c30 + in + P.specialize E.RecordExpr (expression syntaxVersion) + ) |> P.bind (\( value, end ) -> Space.checkIndent end E.RecordIndentEnd @@ -310,7 +354,11 @@ record syntaxVersion start = P.inContext E.Record (P.word1 '{' E.Start) <| (Space.chompAndCheckIndent E.RecordSpace E.RecordIndentOpen |> P.bind - (\_ -> + (\c31 -> + let + _ = + Debug.log "c31" c31 + in P.oneOf E.RecordOpen [ P.word1 '}' E.RecordOpen |> P.bind (\_ -> P.addEnd start (Src.Record [])) @@ -323,9 +371,23 @@ record syntaxVersion start = |> P.bind (\starter -> Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals - |> P.bind (\_ -> P.word1 '|' E.RecordEquals) + |> P.bind + (\c32 -> + let + _ = + Debug.log "c32" c32 + in + P.word1 '|' E.RecordEquals + ) |> P.bind (\_ -> Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField) - |> P.bind (\_ -> chompField syntaxVersion) + |> P.bind + (\c33 -> + let + _ = + Debug.log "c33" c33 + in + chompField syntaxVersion + ) |> P.bind (\firstField -> chompFields syntaxVersion [ firstField ]) |> P.bind (\fields -> P.addEnd start (Src.Update starter fields)) ) @@ -334,9 +396,23 @@ record syntaxVersion start = |> P.bind (\starter -> Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals - |> P.bind (\_ -> P.word1 '=' E.RecordEquals) + |> P.bind + (\c34 -> + let + _ = + Debug.log "c34" c34 + in + P.word1 '=' E.RecordEquals + ) |> P.bind (\_ -> Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr) - |> P.bind (\_ -> P.specialize E.RecordExpr (expression syntaxVersion)) + |> P.bind + (\c35 -> + let + _ = + Debug.log "c35" c35 + in + P.specialize E.RecordExpr (expression syntaxVersion) + ) |> P.bind (\( value, end ) -> Space.checkIndent end E.RecordIndentEnd @@ -450,7 +526,14 @@ chompFields syntaxVersion fields = P.oneOf E.RecordEnd [ P.word1 ',' E.RecordEnd |> P.bind (\_ -> Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField) - |> P.bind (\_ -> chompField syntaxVersion) + |> P.bind + (\c36 -> + let + _ = + Debug.log "c36" c36 + in + chompField syntaxVersion + ) |> P.bind (\f -> chompFields syntaxVersion (f :: fields)) , P.word1 '}' E.RecordEnd |> P.fmap (\_ -> List.reverse fields) @@ -463,9 +546,23 @@ chompField syntaxVersion = |> P.bind (\key -> Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals - |> P.bind (\_ -> P.word1 '=' E.RecordEquals) + |> P.bind + (\c37 -> + let + _ = + Debug.log "c37" c37 + in + P.word1 '=' E.RecordEquals + ) |> P.bind (\_ -> Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr) - |> P.bind (\_ -> P.specialize E.RecordExpr (expression syntaxVersion)) + |> P.bind + (\c38 -> + let + _ = + Debug.log "c38" c38 + in + P.specialize E.RecordExpr (expression syntaxVersion) + ) |> P.bind (\( value, end ) -> Space.checkIndent end E.RecordIndentEnd @@ -496,7 +593,11 @@ expression syntaxVersion = (\end -> Space.chomp E.Space |> P.bind - (\_ -> + (\c111 -> + let + _ = + Debug.log "c111" c111 + in chompExprEnd syntaxVersion start (State @@ -535,7 +636,11 @@ chompExprEnd syntaxVersion start (State { ops, expr, args, end }) = (\newEnd -> Space.chomp E.Space |> P.bind - (\_ -> + (\c112 -> + let + _ = + Debug.log "c112" c112 + in chompExprEnd syntaxVersion start (State @@ -554,7 +659,14 @@ chompExprEnd syntaxVersion start (State { ops, expr, args, end }) = |> P.bind (\((A.At (A.Region opStart opEnd) opName) as op) -> Space.chompAndCheckIndent E.Space (E.IndentOperatorRight opName) - |> P.bind (\_ -> P.getPosition) + |> P.bind + (\c39 -> + let + _ = + Debug.log "c39" c39 + in + P.getPosition + ) |> P.bind (\newStart -> if "-" == opName && end /= opStart && opEnd == newStart then @@ -567,8 +679,11 @@ chompExprEnd syntaxVersion start (State { ops, expr, args, end }) = (\newEnd -> Space.chomp E.Space |> P.bind - (\_ -> + (\c113 -> let + _ = + Debug.log "c113" c113 + arg : A.Located Src.Expr_ arg = A.at opStart newEnd (Src.Negate negatedExpr) @@ -602,8 +717,11 @@ chompExprEnd syntaxVersion start (State { ops, expr, args, end }) = (\newEnd -> Space.chomp E.Space |> P.bind - (\_ -> + (\c114 -> let + _ = + Debug.log "c114" c114 + newOps : List ( Src.Expr, A.Located Name.Name ) newOps = ( toCall expr args, op ) :: ops @@ -697,21 +815,38 @@ if_ syntaxVersion start = chompIfEnd : SyntaxVersion -> A.Position -> List ( Src.Expr, Src.Expr ) -> Space.Parser E.If Src.Expr chompIfEnd syntaxVersion start branches = Space.chompAndCheckIndent E.IfSpace E.IfIndentCondition - |> P.bind (\_ -> P.specialize E.IfCondition (expression syntaxVersion)) + |> P.bind + (\c40 -> + let + _ = + Debug.log "c40" c40 + in + P.specialize E.IfCondition (expression syntaxVersion) + ) |> P.bind (\( condition, condEnd ) -> Space.checkIndent condEnd E.IfIndentThen |> P.bind (\_ -> Keyword.then_ E.IfThen) |> P.bind (\_ -> Space.chompAndCheckIndent E.IfSpace E.IfIndentThenBranch) - |> P.bind (\_ -> P.specialize E.IfThenBranch (expression syntaxVersion)) + |> P.bind + (\c41 -> + let + _ = + Debug.log "c41" c41 + in + P.specialize E.IfThenBranch (expression syntaxVersion) + ) |> P.bind (\( thenBranch, thenEnd ) -> Space.checkIndent thenEnd E.IfIndentElse |> P.bind (\_ -> Keyword.else_ E.IfElse) |> P.bind (\_ -> Space.chompAndCheckIndent E.IfSpace E.IfIndentElseBranch) |> P.bind - (\_ -> + (\c42 -> let + _ = + Debug.log "c42" c42 + newBranches : List ( Src.Expr, Src.Expr ) newBranches = ( condition, thenBranch ) :: branches @@ -743,15 +878,36 @@ function : SyntaxVersion -> A.Position -> Space.Parser E.Expr Src.Expr function syntaxVersion start = P.inContext E.Func (P.word1 '\\' E.Start) <| (Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArg - |> P.bind (\_ -> P.specialize E.FuncArg (Pattern.term syntaxVersion)) + |> P.bind + (\c43 -> + let + _ = + Debug.log "c43" c43 + in + P.specialize E.FuncArg (Pattern.term syntaxVersion) + ) |> P.bind (\arg -> Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow - |> P.bind (\_ -> chompArgs syntaxVersion [ arg ]) + |> P.bind + (\c44 -> + let + _ = + Debug.log "c44" c44 + in + chompArgs syntaxVersion [ arg ] + ) |> P.bind (\revArgs -> Space.chompAndCheckIndent E.FuncSpace E.FuncIndentBody - |> P.bind (\_ -> P.specialize E.FuncBody (expression syntaxVersion)) + |> P.bind + (\c45 -> + let + _ = + Debug.log "c45" c45 + in + P.specialize E.FuncBody (expression syntaxVersion) + ) |> P.fmap (\( body, end ) -> let @@ -773,7 +929,14 @@ chompArgs syntaxVersion revArgs = |> P.bind (\arg -> Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow - |> P.bind (\_ -> chompArgs syntaxVersion (arg :: revArgs)) + |> P.bind + (\c46 -> + let + _ = + Debug.log "c46" c46 + in + chompArgs syntaxVersion (arg :: revArgs) + ) ) , P.word2 '-' '>' E.FuncArrow |> P.fmap (\_ -> revArgs) @@ -788,14 +951,25 @@ case_ : SyntaxVersion -> A.Position -> Space.Parser E.Expr Src.Expr case_ syntaxVersion start = P.inContext E.Case (Keyword.case_ E.Start) <| (Space.chompAndCheckIndent E.CaseSpace E.CaseIndentExpr - |> P.bind (\_ -> P.specialize E.CaseExpr (expression syntaxVersion)) + |> P.bind + (\c47 -> + let + _ = + Debug.log "c47" c47 + in + P.specialize E.CaseExpr (expression syntaxVersion) + ) |> P.bind (\( expr, exprEnd ) -> Space.checkIndent exprEnd E.CaseIndentOf |> P.bind (\_ -> Keyword.of_ E.CaseOf) |> P.bind (\_ -> Space.chompAndCheckIndent E.CaseSpace E.CaseIndentPattern) |> P.bind - (\_ -> + (\c48 -> + let + _ = + Debug.log "c48" c48 + in P.withIndent <| (chompBranch syntaxVersion |> P.bind @@ -822,7 +996,14 @@ chompBranch syntaxVersion = Space.checkIndent patternEnd E.CaseIndentArrow |> P.bind (\_ -> P.word2 '-' '>' E.CaseArrow) |> P.bind (\_ -> Space.chompAndCheckIndent E.CaseSpace E.CaseIndentBranch) - |> P.bind (\_ -> P.specialize E.CaseBranch (expression syntaxVersion)) + |> P.bind + (\c49 -> + let + _ = + Debug.log "c49" c49 + in + P.specialize E.CaseBranch (expression syntaxVersion) + ) |> P.fmap (\( branchExpr, end ) -> ( ( pattern, branchExpr ), end )) ) @@ -847,7 +1028,11 @@ let_ syntaxVersion start = ((P.withBacksetIndent 3 <| (Space.chompAndCheckIndent E.LetSpace E.LetIndentDef |> P.bind - (\_ -> + (\c50 -> + let + _ = + Debug.log "c50" c50 + in P.withIndent <| (chompLetDef syntaxVersion |> P.bind (\( def, end ) -> chompLetDefs syntaxVersion [ def ] end) @@ -860,7 +1045,14 @@ let_ syntaxVersion start = Space.checkIndent defsEnd E.LetIndentIn |> P.bind (\_ -> Keyword.in_ E.LetIn) |> P.bind (\_ -> Space.chompAndCheckIndent E.LetSpace E.LetIndentBody) - |> P.bind (\_ -> P.specialize E.LetBody (expression syntaxVersion)) + |> P.bind + (\c51 -> + let + _ = + Debug.log "c51" c51 + in + P.specialize E.LetBody (expression syntaxVersion) + ) |> P.fmap (\( body, end ) -> ( A.at start end (Src.Let defs body), end ) @@ -903,11 +1095,22 @@ definition syntaxVersion = P.specialize (E.LetDef name) <| (Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals |> P.bind - (\_ -> + (\c52 -> + let + _ = + Debug.log "c52" c52 + in P.oneOf E.DefEquals [ P.word1 ':' E.DefEquals |> P.bind (\_ -> Space.chompAndCheckIndent E.DefSpace E.DefIndentType) - |> P.bind (\_ -> P.specialize E.DefType Type.expression) + |> P.bind + (\c53 -> + let + _ = + Debug.log "c53" c53 + in + P.specialize E.DefType Type.expression + ) |> P.bind (\( tipe, _ ) -> Space.checkAligned E.DefAlignment @@ -915,7 +1118,14 @@ definition syntaxVersion = |> P.bind (\defName -> Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals - |> P.bind (\_ -> chompDefArgsAndBody syntaxVersion start defName (Just tipe) []) + |> P.bind + (\c54 -> + let + _ = + Debug.log "c54" c54 + in + chompDefArgsAndBody syntaxVersion start defName (Just tipe) [] + ) ) ) , chompDefArgsAndBody syntaxVersion start aname Nothing [] @@ -932,11 +1142,25 @@ chompDefArgsAndBody syntaxVersion start name tipe revArgs = |> P.bind (\arg -> Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals - |> P.bind (\_ -> chompDefArgsAndBody syntaxVersion start name tipe (arg :: revArgs)) + |> P.bind + (\c55 -> + let + _ = + Debug.log "c55" c55 + in + chompDefArgsAndBody syntaxVersion start name tipe (arg :: revArgs) + ) ) , P.word1 '=' E.DefEquals |> P.bind (\_ -> Space.chompAndCheckIndent E.DefSpace E.DefIndentBody) - |> P.bind (\_ -> P.specialize E.DefBody (expression syntaxVersion)) + |> P.bind + (\c56 -> + let + _ = + Debug.log "c56" c56 + in + P.specialize E.DefBody (expression syntaxVersion) + ) |> P.fmap (\( body, end ) -> ( A.at start end (Src.Define name (List.reverse revArgs) body tipe) @@ -990,9 +1214,23 @@ destructure syntaxVersion = |> P.bind (\pattern -> Space.chompAndCheckIndent E.DestructSpace E.DestructIndentEquals - |> P.bind (\_ -> P.word1 '=' E.DestructEquals) + |> P.bind + (\c57 -> + let + _ = + Debug.log "c57" c57 + in + P.word1 '=' E.DestructEquals + ) |> P.bind (\_ -> Space.chompAndCheckIndent E.DestructSpace E.DestructIndentBody) - |> P.bind (\_ -> P.specialize E.DestructBody (expression syntaxVersion)) + |> P.bind + (\c58 -> + let + _ = + Debug.log "c58" c58 + in + P.specialize E.DestructBody (expression syntaxVersion) + ) |> P.fmap (\( expr, end ) -> ( A.at start end (Src.Destruct pattern expr) diff --git a/src/Compiler/Parse/Module.elm b/src/Compiler/Parse/Module.elm index be3fb7af2..b85b84106 100644 --- a/src/Compiler/Parse/Module.elm +++ b/src/Compiler/Parse/Module.elm @@ -1,7 +1,12 @@ module Compiler.Parse.Module exposing - ( ProjectType(..) + ( Effects(..) + , Header + , Module + , ProjectType(..) , chompImport , chompImports + , chompModule + , defaultHeader , fromByteString , isKernel ) @@ -69,7 +74,8 @@ isKernel projectType = type alias Module = - { header : Maybe Header + { initialComments : List Space.Comment + , header : Maybe Header , imports : List Src.Import , infixes : List (A.Located Src.Infix) , decls : List Decl.Decl @@ -80,7 +86,7 @@ chompModule : SyntaxVersion -> ProjectType -> P.Parser E.Module Module chompModule syntaxVersion projectType = chompHeader |> P.bind - (\header -> + (\( initialComments, header ) -> chompImports (if isCore projectType then [] @@ -102,6 +108,7 @@ chompModule syntaxVersion projectType = |> P.fmap (\decls -> Module + initialComments header imports infixes @@ -123,7 +130,14 @@ checkModule syntaxVersion projectType module_ = categorizeDecls [] [] [] [] module_.decls in case module_.header of - Just { name, effects, exports, docs } -> + Just ({ effects, docs } as header) -> + let + ( _, name, _ ) = + header.name + + ( _, exports, _ ) = + header.exports + in checkEffects projectType ports effects |> Result.map (Src.Module syntaxVersion @@ -142,7 +156,7 @@ checkModule syntaxVersion projectType module_ = (Src.Module syntaxVersion Nothing (A.At A.one Src.Open) - (Src.NoDocs A.one) + (toDocs (Err A.one) module_.decls) module_.imports values unions @@ -208,7 +222,7 @@ categorizeDecls values unions aliases ports decls = decl :: otherDecls -> case decl of - Decl.Value _ value -> + Decl.Value _ _ value -> categorizeDecls (value :: values) unions aliases ports otherDecls Decl.Union _ union -> @@ -232,7 +246,7 @@ toDocs comment decls = Src.YesDocs overview (getComments decls []) Err region -> - Src.NoDocs region + Src.NoDocs region (getComments decls []) getComments : List Decl.Decl -> List ( Name.Name, Src.Comment ) -> List ( Name.Name, Src.Comment ) @@ -243,7 +257,7 @@ getComments decls comments = decl :: otherDecls -> case decl of - Decl.Value c (A.At _ (Src.Value n _ _ _)) -> + Decl.Value c _ (A.At _ (Src.Value n _ _ _)) -> getComments otherDecls (addComment c n comments) Decl.Union c (A.At _ (Src.Union n _ _)) -> @@ -270,10 +284,18 @@ addComment maybeComment (A.At _ name) comments = -- FRESH LINES -freshLine : (Row -> Col -> E.Module) -> P.Parser E.Module () +freshLine : (Row -> Col -> E.Module) -> P.Parser E.Module (List Space.Comment) freshLine toFreshLineError = Space.chomp E.ModuleSpace - |> P.bind (\_ -> Space.checkFreshLine toFreshLineError) + |> P.bind + (\comments -> + let + _ = + Debug.log "c115" comments + in + Space.checkFreshLine toFreshLineError + |> P.fmap (\_ -> comments) + ) @@ -312,21 +334,33 @@ chompInfixes infixes = -- MODULE DOC COMMENT -chompModuleDocCommentSpace : P.Parser E.Module (Result A.Region Src.Comment) +chompModuleDocCommentSpace : P.Parser E.Module ( List Space.Comment, Result A.Region Src.Comment ) chompModuleDocCommentSpace = P.addLocation (freshLine E.FreshLine) |> P.bind - (\(A.At region ()) -> + (\(A.At region beforeComments) -> P.oneOfWithFallback [ Space.docComment E.ImportStart E.ModuleSpace |> P.bind (\docComment -> Space.chomp E.ModuleSpace - |> P.bind (\_ -> Space.checkFreshLine E.FreshLine) - |> P.fmap (\_ -> Ok docComment) + |> P.bind + (\afterComments -> + let + _ = + Debug.log "c116" afterComments + in + Space.checkFreshLine E.FreshLine + |> P.fmap + (\_ -> + ( beforeComments ++ afterComments + , Ok docComment + ) + ) + ) ) ] - (Err region) + ( beforeComments, Err region ) ) @@ -335,10 +369,21 @@ chompModuleDocCommentSpace = type alias Header = - { name : A.Located Name.Name + { name : ( List Space.Comment, A.Located Name.Name, List Space.Comment ) , effects : Effects - , exports : A.Located Src.Exposing + , exports : ( List Space.Comment, A.Located Src.Exposing, List Space.Comment ) , docs : Result A.Region Src.Comment + , comments : List Space.Comment + } + + +defaultHeader : Header +defaultHeader = + { name = ( [], A.At A.zero Name.mainModule, [] ) + , effects = NoEffects A.zero + , exports = ( [], A.At A.zero Src.Open, [] ) + , docs = Err A.zero + , comments = [] } @@ -348,107 +393,206 @@ type Effects | Manager A.Region Src.Manager -chompHeader : P.Parser E.Module (Maybe Header) +chompHeader : P.Parser E.Module ( List Space.Comment, Maybe Header ) chompHeader = freshLine E.FreshLine - |> P.bind (\_ -> P.getPosition) |> P.bind - (\start -> - P.oneOfWithFallback - [ -- module MyThing exposing (..) - Keyword.module_ E.ModuleProblem - |> P.bind (\_ -> P.getPosition) - |> P.bind - (\effectEnd -> - Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem - |> P.bind (\_ -> P.addLocation (Var.moduleName E.ModuleName)) + (\initialComments -> + P.getPosition + |> P.bind + (\start -> + P.oneOfWithFallback + [ -- module MyThing exposing (..) + Keyword.module_ E.ModuleProblem + |> P.bind (\_ -> P.getPosition) |> P.bind - (\name -> + (\effectEnd -> Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem - |> P.bind (\_ -> Keyword.exposing_ E.ModuleProblem) - |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem) - |> P.bind (\_ -> P.addLocation (P.specialize E.ModuleExposing exposing_)) |> P.bind - (\exports -> - chompModuleDocCommentSpace - |> P.fmap - (\comment -> - Just <| - Header - name - (NoEffects (A.Region start effectEnd)) - exports - comment + (\beforeNameComments -> + let + _ = + Debug.log "c59" beforeNameComments + in + P.addLocation (Var.moduleName E.ModuleName) + |> P.bind + (\name -> + Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem + |> P.bind + (\afterNameComments -> + let + _ = + Debug.log "c60" afterNameComments + in + Keyword.exposing_ E.ModuleProblem + |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem) + |> P.bind + (\beforeExportsComments -> + let + _ = + Debug.log "c61" beforeExportsComments + in + P.addLocation (P.specialize E.ModuleExposing exposing_) + |> P.bind + (\exports -> + chompModuleDocCommentSpace + |> P.fmap + (\( headerComments, docComment ) -> + Just <| + Header ( beforeNameComments, name, afterNameComments ) + (NoEffects (A.Region start effectEnd)) + ( beforeExportsComments, exports, [] ) + docComment + headerComments + ) + ) + ) + ) ) ) ) - ) - , -- port module MyThing exposing (..) - Keyword.port_ E.PortModuleProblem - |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem) - |> P.bind (\_ -> Keyword.module_ E.PortModuleProblem) - |> P.bind (\_ -> P.getPosition) - |> P.bind - (\effectEnd -> - Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem - |> P.bind (\_ -> P.addLocation (Var.moduleName E.PortModuleName)) + , -- port module MyThing exposing (..) + Keyword.port_ E.PortModuleProblem + |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem) |> P.bind - (\name -> + (\c62 -> + let + _ = + Debug.log "c62" c62 + in + Keyword.module_ E.PortModuleProblem + ) + |> P.bind (\_ -> P.getPosition) + |> P.bind + (\effectEnd -> Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem - |> P.bind (\_ -> Keyword.exposing_ E.PortModuleProblem) - |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem) - |> P.bind (\_ -> P.addLocation (P.specialize E.PortModuleExposing exposing_)) |> P.bind - (\exports -> - chompModuleDocCommentSpace - |> P.fmap - (\comment -> - Just <| - Header - name - (Ports (A.Region start effectEnd)) - exports - comment + (\beforeNameComments -> + let + _ = + Debug.log "c63" beforeNameComments + in + P.addLocation (Var.moduleName E.PortModuleName) + |> P.bind + (\name -> + Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem + |> P.bind + (\afterNameComments -> + let + _ = + Debug.log "c64" afterNameComments + in + Keyword.exposing_ E.PortModuleProblem + |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem) + |> P.bind + (\beforeExportsComments -> + let + _ = + Debug.log "c65" beforeExportsComments + in + P.addLocation (P.specialize E.PortModuleExposing exposing_) + |> P.bind + (\exports -> + chompModuleDocCommentSpace + |> P.fmap + (\( headerComments, docComment ) -> + Just <| + Header ( beforeNameComments, name, afterNameComments ) + (Ports (A.Region start effectEnd)) + ( beforeExportsComments, exports, [] ) + docComment + headerComments + ) + ) + ) + ) ) ) ) - ) - , -- effect module MyThing where { command = MyCmd } exposing (..) - Keyword.effect_ E.Effect - |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.Effect) - |> P.bind (\_ -> Keyword.module_ E.Effect) - |> P.bind (\_ -> P.getPosition) - |> P.bind - (\effectEnd -> - Space.chompAndCheckIndent E.ModuleSpace E.Effect - |> P.bind (\_ -> P.addLocation (Var.moduleName E.ModuleName)) + , -- effect module MyThing where { command = MyCmd } exposing (..) + Keyword.effect_ E.Effect + |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.Effect) + |> P.bind + (\c66 -> + let + _ = + Debug.log "c66" c66 + in + Keyword.module_ E.Effect + ) + |> P.bind (\_ -> P.getPosition) |> P.bind - (\name -> + (\effectEnd -> Space.chompAndCheckIndent E.ModuleSpace E.Effect - |> P.bind (\_ -> Keyword.where_ E.Effect) - |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.Effect) - |> P.bind (\_ -> chompManager) |> P.bind - (\manager -> - Space.chompAndCheckIndent E.ModuleSpace E.Effect - |> P.bind (\_ -> Keyword.exposing_ E.Effect) - |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.Effect) - |> P.bind (\_ -> P.addLocation (P.specialize (\_ -> E.Effect) exposing_)) + (\beforeNameComments -> + let + _ = + Debug.log "c67" beforeNameComments + in + P.addLocation (Var.moduleName E.ModuleName) |> P.bind - (\exports -> - chompModuleDocCommentSpace - |> P.fmap - (\comment -> - Just <| - Header name (Manager (A.Region start effectEnd) manager) exports comment + (\name -> + Space.chompAndCheckIndent E.ModuleSpace E.Effect + |> P.bind + (\afterNameComments -> + let + _ = + Debug.log "c68" afterNameComments + in + Keyword.where_ E.Effect + |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.Effect) + |> P.bind + (\c69 -> + let + _ = + Debug.log "c69" c69 + in + chompManager + ) + |> P.bind + (\manager -> + Space.chompAndCheckIndent E.ModuleSpace E.Effect + |> P.bind + (\c70 -> + let + _ = + Debug.log "c70" c70 + in + Keyword.exposing_ E.Effect + ) + |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.Effect) + |> P.bind + (\beforeExportsComments -> + let + _ = + Debug.log "c71" beforeExportsComments + in + P.addLocation (P.specialize (\_ -> E.Effect) exposing_) + |> P.bind + (\exports -> + chompModuleDocCommentSpace + |> P.fmap + (\( headerComments, docComment ) -> + Just <| + Header ( beforeNameComments, name, afterNameComments ) + (Manager (A.Region start effectEnd) manager) + ( beforeExportsComments, exports, [] ) + docComment + headerComments + ) + ) + ) + ) ) ) ) ) - ) - ] - -- default header - Nothing + ] + -- default header + Nothing + ) + |> P.fmap (Tuple.pair initialComments) ) @@ -527,9 +671,10 @@ chompSubscription = |> P.bind (\_ -> P.addLocation (Var.upper E.Effect)) -spaces_em : P.Parser E.Module () +spaces_em : P.Parser E.Module (List Space.Comment) spaces_em = Space.chompAndCheckIndent E.ModuleSpace E.Effect + |> P.fmap (Debug.log "c72") @@ -549,12 +694,23 @@ chompImport : P.Parser E.Module Src.Import chompImport = Keyword.import_ E.ImportStart |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentName) - |> P.bind (\_ -> P.addLocation (Var.moduleName E.ImportName)) + |> P.bind + (\c73 -> + let + _ = + Debug.log "c73" c73 + in + P.addLocation (Var.moduleName E.ImportName) + ) |> P.bind (\((A.At (A.Region _ end) _) as name) -> Space.chomp E.ModuleSpace |> P.bind - (\_ -> + (\c117 -> + let + _ = + Debug.log "c117" c117 + in P.oneOf E.ImportEnd [ Space.checkFreshLine E.ImportEnd |> P.fmap (\_ -> Src.Import name Nothing (Src.Explicit [])) @@ -575,7 +731,14 @@ chompAs : A.Located Name.Name -> P.Parser E.Module Src.Import chompAs name = Keyword.as_ E.ImportAs |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias) - |> P.bind (\_ -> Var.upper E.ImportAlias) + |> P.bind + (\c74 -> + let + _ = + Debug.log "c74" c74 + in + Var.upper E.ImportAlias + ) |> P.bind (\alias -> P.getPosition @@ -583,7 +746,11 @@ chompAs name = (\end -> Space.chomp E.ModuleSpace |> P.bind - (\_ -> + (\c118 -> + let + _ = + Debug.log "c118" c118 + in P.oneOf E.ImportEnd [ Space.checkFreshLine E.ImportEnd |> P.fmap (\_ -> Src.Import name (Just alias) (Src.Explicit [])) @@ -599,7 +766,14 @@ chompExposing : A.Located Name.Name -> Maybe Name.Name -> P.Parser E.Module Src. chompExposing name maybeAlias = Keyword.exposing_ E.ImportExposing |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingList) - |> P.bind (\_ -> P.specialize E.ImportExposingList exposing_) + |> P.bind + (\c75 -> + let + _ = + Debug.log "c75" c75 + in + P.specialize E.ImportExposingList exposing_ + ) |> P.bind (\exposed -> freshLine E.ImportEnd @@ -616,17 +790,35 @@ exposing_ = P.word1 '(' E.ExposingStart |> P.bind (\_ -> Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue) |> P.bind - (\_ -> + (\c76 -> + let + _ = + Debug.log "c76" c76 + in P.oneOf E.ExposingValue [ P.word2 '.' '.' E.ExposingValue |> P.bind (\_ -> Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd) - |> P.bind (\_ -> P.word1 ')' E.ExposingEnd) + |> P.bind + (\c77 -> + let + _ = + Debug.log "c77" c77 + in + P.word1 ')' E.ExposingEnd + ) |> P.fmap (\_ -> Src.Open) , chompExposed |> P.bind (\exposed -> Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd - |> P.bind (\_ -> P.loop exposingHelp [ exposed ]) + |> P.bind + (\c78 -> + let + _ = + Debug.log "c78" c78 + in + P.loop exposingHelp [ exposed ] + ) ) ] ) @@ -637,11 +829,25 @@ exposingHelp revExposed = P.oneOf E.ExposingEnd [ P.word1 ',' E.ExposingEnd |> P.bind (\_ -> Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue) - |> P.bind (\_ -> chompExposed) + |> P.bind + (\c79 -> + let + _ = + Debug.log "c79" c79 + in + chompExposed + ) |> P.bind (\exposed -> Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd - |> P.fmap (\_ -> P.Loop (exposed :: revExposed)) + |> P.fmap + (\c80 -> + let + _ = + Debug.log "c80" c80 + in + P.Loop (exposed :: revExposed) + ) ) , P.word1 ')' E.ExposingEnd |> P.fmap (\_ -> P.Done (Src.Explicit (List.reverse revExposed))) @@ -676,7 +882,11 @@ chompExposed = (\end -> Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd |> P.bind - (\_ -> + (\c81 -> + let + _ = + Debug.log "c81" c81 + in privacy |> P.fmap (Src.Upper (A.at start end name)) ) @@ -691,7 +901,14 @@ privacy = P.oneOfWithFallback [ P.word1 '(' E.ExposingTypePrivacy |> P.bind (\_ -> Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy) - |> P.bind (\_ -> P.getPosition) + |> P.bind + (\c82 -> + let + _ = + Debug.log "c82" c82 + in + P.getPosition + ) |> P.bind (\start -> P.word2 '.' '.' E.ExposingTypePrivacy @@ -699,7 +916,14 @@ privacy = |> P.bind (\end -> Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy - |> P.bind (\_ -> P.word1 ')' E.ExposingTypePrivacy) + |> P.bind + (\c83 -> + let + _ = + Debug.log "c83" c83 + in + P.word1 ')' E.ExposingTypePrivacy + ) |> P.fmap (\_ -> Src.Public (A.Region start end)) ) ) diff --git a/src/Compiler/Parse/Pattern.elm b/src/Compiler/Parse/Pattern.elm index 64099b49d..b153eb1a4 100644 --- a/src/Compiler/Parse/Pattern.elm +++ b/src/Compiler/Parse/Pattern.elm @@ -158,13 +158,24 @@ record start = P.inContext E.PRecord (P.word1 '{' E.PStart) <| (Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentOpen |> P.bind - (\_ -> + (\c84 -> + let + _ = + Debug.log "c84" c84 + in P.oneOf E.PRecordOpen [ P.addLocation (Var.lower E.PRecordField) |> P.bind (\var -> Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd - |> P.bind (\_ -> recordHelp start [ var ]) + |> P.bind + (\c85 -> + let + _ = + Debug.log "c85" c85 + in + recordHelp start [ var ] + ) ) , P.word1 '}' E.PRecordEnd |> P.bind (\_ -> P.addEnd start (Src.PRecord [])) @@ -178,11 +189,25 @@ recordHelp start vars = P.oneOf E.PRecordEnd [ P.word1 ',' E.PRecordEnd |> P.bind (\_ -> Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentField) - |> P.bind (\_ -> P.addLocation (Var.lower E.PRecordField)) + |> P.bind + (\c86 -> + let + _ = + Debug.log "c86" c86 + in + P.addLocation (Var.lower E.PRecordField) + ) |> P.bind (\var -> Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd - |> P.bind (\_ -> recordHelp start (var :: vars)) + |> P.bind + (\c87 -> + let + _ = + Debug.log "c87" c87 + in + recordHelp start (var :: vars) + ) ) , P.word1 '}' E.PRecordEnd |> P.bind (\_ -> P.addEnd start (Src.PRecord vars)) @@ -198,7 +223,11 @@ tuple syntaxVersion start = P.inContext E.PTuple (P.word1 '(' E.PStart) <| (Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExpr1 |> P.bind - (\_ -> + (\c88 -> + let + _ = + Debug.log "c88" c88 + in P.oneOf E.PTupleOpen [ P.specialize E.PTupleExpr (expression syntaxVersion) |> P.bind @@ -218,7 +247,14 @@ tupleHelp syntaxVersion start firstPattern revPatterns = P.oneOf E.PTupleEnd [ P.word1 ',' E.PTupleEnd |> P.bind (\_ -> Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExprN) - |> P.bind (\_ -> P.specialize E.PTupleExpr (expression syntaxVersion)) + |> P.bind + (\c89 -> + let + _ = + Debug.log "c89" c89 + in + P.specialize E.PTupleExpr (expression syntaxVersion) + ) |> P.bind (\( pattern, end ) -> Space.checkIndent end E.PTupleIndentEnd @@ -246,7 +282,11 @@ list syntaxVersion start = P.inContext E.PList (P.word1 '[' E.PStart) <| (Space.chompAndCheckIndent E.PListSpace E.PListIndentOpen |> P.bind - (\_ -> + (\c90 -> + let + _ = + Debug.log "c90" c90 + in P.oneOf E.PListOpen [ P.specialize E.PListExpr (expression syntaxVersion) |> P.bind @@ -266,7 +306,14 @@ listHelp syntaxVersion start patterns = P.oneOf E.PListEnd [ P.word1 ',' E.PListEnd |> P.bind (\_ -> Space.chompAndCheckIndent E.PListSpace E.PListIndentExpr) - |> P.bind (\_ -> P.specialize E.PListExpr (expression syntaxVersion)) + |> P.bind + (\c91 -> + let + _ = + Debug.log "c91" c91 + in + P.specialize E.PListExpr (expression syntaxVersion) + ) |> P.bind (\( pattern, end ) -> Space.checkIndent end E.PListIndentEnd @@ -300,12 +347,26 @@ exprHelp syntaxVersion start revPatterns ( pattern, end ) = [ Space.checkIndent end E.PIndentStart |> P.bind (\_ -> P.word2 ':' ':' E.PStart) |> P.bind (\_ -> Space.chompAndCheckIndent E.PSpace E.PIndentStart) - |> P.bind (\_ -> exprPart syntaxVersion) + |> P.bind + (\c92 -> + let + _ = + Debug.log "c92" c92 + in + exprPart syntaxVersion + ) |> P.bind (\ePart -> exprHelp syntaxVersion start (pattern :: revPatterns) ePart) , Space.checkIndent end E.PIndentStart |> P.bind (\_ -> Keyword.as_ E.PStart) |> P.bind (\_ -> Space.chompAndCheckIndent E.PSpace E.PIndentAlias) - |> P.bind (\_ -> P.getPosition) + |> P.bind + (\c93 -> + let + _ = + Debug.log "c93" c93 + in + P.getPosition + ) |> P.bind (\nameStart -> Var.lower E.PAlias @@ -316,8 +377,11 @@ exprHelp syntaxVersion start revPatterns ( pattern, end ) = (\newEnd -> Space.chomp E.PSpace |> P.fmap - (\_ -> + (\c119 -> let + _ = + Debug.log "c119" c119 + alias_ : A.Located Name.Name alias_ = A.at nameStart newEnd name @@ -361,7 +425,14 @@ exprPart syntaxVersion = |> P.bind (\((A.At (A.Region _ end) _) as eterm) -> Space.chomp E.PSpace - |> P.fmap (\_ -> ( eterm, end )) + |> P.fmap + (\c120 -> + let + _ = + Debug.log "c120" c120 + in + ( eterm, end ) + ) ) ] @@ -373,7 +444,11 @@ exprTermHelp syntaxVersion region upper start revArgs = (\end -> Space.chomp E.PSpace |> P.bind - (\_ -> + (\c121 -> + let + _ = + Debug.log "c121" c121 + in P.oneOfWithFallback [ Space.checkIndent end E.PIndentStart |> P.bind (\_ -> term syntaxVersion) diff --git a/src/Compiler/Parse/Space.elm b/src/Compiler/Parse/Space.elm index e45c4a414..645a9431d 100644 --- a/src/Compiler/Parse/Space.elm +++ b/src/Compiler/Parse/Space.elm @@ -1,5 +1,6 @@ module Compiler.Parse.Space exposing - ( Parser + ( Comment(..) + , Parser , checkAligned , checkFreshLine , checkIndent @@ -15,6 +16,18 @@ import Compiler.Reporting.Error.Syntax as E +-- COMMENT + + +type Comment + = BlockComment (List String) + | LineComment String + | CommentTrickOpener + | CommentTrickCloser + | CommentTrickBlock String + + + -- SPACE PARSING @@ -26,13 +39,13 @@ type alias Parser x a = -- CHOMP -chomp : (E.Space -> Row -> Col -> x) -> P.Parser x () +chomp : (E.Space -> Row -> Col -> x) -> P.Parser x (List Comment) chomp toError = P.Parser <| \(P.State src pos end indent row col) -> let - ( ( status, newPos ), ( newRow, newCol ) ) = - eat Spaces src pos end row col + ( ( status, comments, newPos ), ( newRow, newCol ) ) = + eat EatSpaces [] src pos end row col in case status of Good -> @@ -41,7 +54,7 @@ chomp toError = newState = P.State src newPos end indent newRow newCol in - P.Cok () newState + P.Cok (List.reverse comments) newState HasTab -> P.Cerr newRow newCol (toError E.HasTab) @@ -91,13 +104,13 @@ checkFreshLine toError = -- CHOMP AND CHECK -chompAndCheckIndent : (E.Space -> Row -> Col -> x) -> (Row -> Col -> x) -> P.Parser x () +chompAndCheckIndent : (E.Space -> Row -> Col -> x) -> (Row -> Col -> x) -> P.Parser x (List Comment) chompAndCheckIndent toSpaceError toIndentError = P.Parser <| \(P.State src pos end indent row col) -> let - ( ( status, newPos ), ( newRow, newCol ) ) = - eat Spaces src pos end row col + ( ( status, comments, newPos ), ( newRow, newCol ) ) = + eat EatSpaces [] src pos end row col in case status of Good -> @@ -107,7 +120,7 @@ chompAndCheckIndent toSpaceError toIndentError = newState = P.State src newPos end indent newRow newCol in - P.Cok () newState + P.Cok (List.reverse comments) newState else P.Cerr row col toIndentError @@ -129,9 +142,9 @@ chompAndCheckIndent toSpaceError toIndentError = type EatType - = Spaces - | LineComment - | MultiComment + = EatSpaces + | EatLineComment Int + | EatMultiComment type Status @@ -140,23 +153,23 @@ type Status | EndlessMultiComment -eat : EatType -> String -> Int -> Int -> Row -> Col -> ( ( Status, Int ), ( Row, Col ) ) -eat eatType src pos end row col = +eat : EatType -> List Comment -> String -> Int -> Int -> Row -> Col -> ( ( Status, List Comment, Int ), ( Row, Col ) ) +eat eatType comments src pos end row col = case eatType of - Spaces -> + EatSpaces -> if pos >= end then - ( ( Good, pos ), ( row, col ) ) + ( ( Good, comments, pos ), ( row, col ) ) else case P.unsafeIndex src pos of ' ' -> - eat Spaces src (pos + 1) end row (col + 1) + eat EatSpaces comments src (pos + 1) end row (col + 1) '\n' -> - eat Spaces src (pos + 1) end (row + 1) 1 + eat EatSpaces comments src (pos + 1) end (row + 1) 1 '{' -> - eat MultiComment src pos end row col + eat EatMultiComment comments src pos end row col '-' -> let @@ -165,23 +178,23 @@ eat eatType src pos end row col = pos + 1 in if pos1 < end && P.unsafeIndex src pos1 == '-' then - eat LineComment src (pos + 2) end row (col + 2) + eat (EatLineComment (pos + 2)) comments src (pos + 2) end row (col + 2) else - ( ( Good, pos ), ( row, col ) ) + ( ( Good, comments, pos ), ( row, col ) ) '\u{000D}' -> - eat Spaces src (pos + 1) end row col + eat EatSpaces comments src (pos + 1) end row col '\t' -> - ( ( HasTab, pos ), ( row, col ) ) + ( ( HasTab, comments, pos ), ( row, col ) ) _ -> - ( ( Good, pos ), ( row, col ) ) + ( ( Good, comments, pos ), ( row, col ) ) - LineComment -> + EatLineComment startPos -> if pos >= end then - ( ( Good, pos ), ( row, col ) ) + ( ( Good, comments, pos ), ( row, col ) ) else let @@ -190,7 +203,11 @@ eat eatType src pos end row col = P.unsafeIndex src pos in if word == '\n' then - eat Spaces src (pos + 1) end (row + 1) 1 + let + newComment = + LineComment (String.slice startPos pos src) + in + eat EatSpaces (newComment :: comments) src (pos + 1) end (row + 1) 1 else let @@ -198,16 +215,16 @@ eat eatType src pos end row col = newPos = pos + P.getCharWidth word in - eat LineComment src newPos end row (col + 1) + eat (EatLineComment startPos) comments src newPos end row (col + 1) - MultiComment -> + EatMultiComment -> let pos2 : Int pos2 = pos + 2 in if pos2 >= end then - ( ( Good, pos ), ( row, col ) ) + ( ( Good, comments, pos ), ( row, col ) ) else let @@ -217,7 +234,7 @@ eat eatType src pos end row col = in if P.unsafeIndex src pos1 == '-' then if P.unsafeIndex src pos2 == '|' then - ( ( Good, pos ), ( row, col ) ) + ( ( Good, comments, pos ), ( row, col ) ) else let @@ -226,16 +243,20 @@ eat eatType src pos end row col = in case status of MultiGood -> - eat Spaces src newPos end newRow newCol + let + newComment = + BlockComment (String.lines (String.slice pos2 (newPos - 2) src)) + in + eat EatSpaces (newComment :: comments) src newPos end newRow newCol MultiTab -> - ( ( HasTab, newPos ), ( newRow, newCol ) ) + ( ( HasTab, comments, newPos ), ( newRow, newCol ) ) MultiEndless -> - ( ( EndlessMultiComment, pos ), ( row, col ) ) + ( ( EndlessMultiComment, comments, pos ), ( row, col ) ) else - ( ( Good, pos ), ( row, col ) ) + ( ( Good, comments, pos ), ( row, col ) ) type MultiStatus diff --git a/src/Compiler/Parse/Type.elm b/src/Compiler/Parse/Type.elm index 88cb792d8..1ce6c866c 100644 --- a/src/Compiler/Parse/Type.elm +++ b/src/Compiler/Parse/Type.elm @@ -56,7 +56,11 @@ term = |> P.bind (\_ -> P.addEnd start Src.TUnit) , Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentType1 |> P.bind - (\_ -> + (\c94 -> + let + _ = + Debug.log "c94" c94 + in P.specialize E.TTupleType expression |> P.bind (\( tipe, end ) -> @@ -69,7 +73,11 @@ term = P.inContext E.TRecord (P.word1 '{' E.TStart) <| (Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentOpen |> P.bind - (\_ -> + (\c95 -> + let + _ = + Debug.log "c95" c95 + in P.oneOf E.TRecordOpen [ P.word1 '}' E.TRecordEnd |> P.bind (\_ -> P.addEnd start (Src.TRecord [] Nothing)) @@ -78,14 +86,22 @@ term = (\name -> Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentColon |> P.bind - (\_ -> + (\c96 -> + let + _ = + Debug.log "c96" c96 + in P.oneOf E.TRecordColon [ P.word1 '|' E.TRecordColon |> P.bind (\_ -> Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentField |> P.bind - (\_ -> + (\c97 -> + let + _ = + Debug.log "c97" c97 + in chompField |> P.bind (\field -> @@ -99,7 +115,11 @@ term = (\_ -> Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentType |> P.bind - (\_ -> + (\c98 -> + let + _ = + Debug.log "c98" c98 + in P.specialize E.TRecordType expression |> P.bind (\( tipe, end ) -> @@ -140,7 +160,14 @@ expression = |> P.bind (\end -> Space.chomp E.TSpace - |> P.fmap (\_ -> ( eterm, end )) + |> P.fmap + (\c122 -> + let + _ = + Debug.log "c122" c122 + in + ( eterm, end ) + ) ) ) ] @@ -157,7 +184,11 @@ expression = (\_ -> Space.chompAndCheckIndent E.TSpace E.TIndentStart |> P.bind - (\_ -> + (\c99 -> + let + _ = + Debug.log "c99" c99 + in expression |> P.fmap (\( tipe2, end2 ) -> @@ -191,7 +222,11 @@ app start = (\upperEnd -> Space.chomp E.TSpace |> P.bind - (\_ -> + (\c123 -> + let + _ = + Debug.log "c123" c123 + in chompArgs [] upperEnd |> P.fmap (\( args, end ) -> @@ -230,7 +265,11 @@ chompArgs args end = (\newEnd -> Space.chomp E.TSpace |> P.bind - (\_ -> + (\c124 -> + let + _ = + Debug.log "c124" c124 + in chompArgs (arg :: args) newEnd ) ) @@ -252,7 +291,11 @@ chompTupleEnd start firstType revTypes = (\_ -> Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentTypeN |> P.bind - (\_ -> + (\c100 -> + let + _ = + Debug.log "c100" c100 + in P.specialize E.TTupleType expression |> P.bind (\( tipe, end ) -> @@ -293,7 +336,11 @@ chompRecordEnd fields = (\_ -> Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentField |> P.bind - (\_ -> + (\c101 -> + let + _ = + Debug.log "c101" c101 + in chompField |> P.bind (\field -> @@ -313,13 +360,21 @@ chompField = (\name -> Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentColon |> P.bind - (\_ -> + (\c102 -> + let + _ = + Debug.log "c102" c102 + in P.word1 ':' E.TRecordColon |> P.bind (\_ -> Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentType |> P.bind - (\_ -> + (\c103 -> + let + _ = + Debug.log "c103" c103 + in P.specialize E.TRecordType expression |> P.bind (\( tipe, end ) -> @@ -343,7 +398,11 @@ variant = (\((A.At (A.Region _ nameEnd) _) as name) -> Space.chomp E.CT_Space |> P.bind - (\_ -> + (\c125 -> + let + _ = + Debug.log "c125" c125 + in P.specialize E.CT_VariantArg (chompArgs [] nameEnd) |> P.fmap (\( args, end ) -> diff --git a/src/Compiler/Reporting/Annotation.elm b/src/Compiler/Reporting/Annotation.elm index 512f1f742..abd2ac753 100644 --- a/src/Compiler/Reporting/Annotation.elm +++ b/src/Compiler/Reporting/Annotation.elm @@ -4,6 +4,7 @@ module Compiler.Reporting.Annotation exposing , Region(..) , at , compareLocated + , isMultiline , locatedDecoder , locatedEncoder , merge @@ -91,6 +92,11 @@ one = Region (Position 1 1) (Position 1 1) +isMultiline : Region -> Bool +isMultiline (Region (Position startRow _) (Position endRow _)) = + startRow /= endRow + + -- ENCODERS and DECODERS diff --git a/src/Node/Format.elm b/src/Node/Format.elm index 7aa0512e4..b9061aea3 100644 --- a/src/Node/Format.elm +++ b/src/Node/Format.elm @@ -1,8 +1,9 @@ module Node.Format exposing (run) -import Elm.Syntax.File -import ElmSyntaxParserLenient -import ElmSyntaxPrint +import Common.Format +import Compiler.Elm.Package as Pkg +import Compiler.Parse.Module as M +import Compiler.Parse.SyntaxVersion as SV @@ -11,20 +12,9 @@ import ElmSyntaxPrint run : String -> Result String String run inputText = - case ElmSyntaxParserLenient.run ElmSyntaxParserLenient.module_ inputText of - Just modu -> - Ok (render modu) - - Nothing -> - -- FIXME missings errs - Err "Something went wrong..." - - - --- RENDER - - -render : Elm.Syntax.File.File -> String -render modul = - ElmSyntaxPrint.module_ modul - |> ElmSyntaxPrint.toString + Common.Format.format SV.Guida (M.Package Pkg.core) inputText + |> Result.mapError + (\_ -> + -- FIXME missings errs + "Something went wrong..." + ) diff --git a/src/Terminal/Format.elm b/src/Terminal/Format.elm index 168af1dac..a5edefd7d 100644 --- a/src/Terminal/Format.elm +++ b/src/Terminal/Format.elm @@ -4,8 +4,12 @@ module Terminal.Format exposing ) import Builder.File as File +import Common.Format +import Compiler.Elm.Package as Pkg +import Compiler.Parse.Module as M +import Compiler.Parse.SyntaxVersion as SV import Compiler.Reporting.Annotation as A -import Compiler.Reporting.Error.Syntax as Syntax +import Compiler.Reporting.Error.Syntax as E import Elm.Syntax.File import ElmSyntaxParserLenient import ElmSyntaxPrint @@ -173,8 +177,10 @@ parseModule ( inputFile, inputText ) = format : ( FilePath, String ) -> Result InfoMessage String -format input = - Result.map render (parseModule input) +format ( inputFile, inputText ) = + -- FIXME fix hardcoded syntaxVersion and projectType + Common.Format.format SV.Elm (M.Package Pkg.core) inputText + |> Result.mapError (\_ -> ParseError inputFile []) doIt : Bool -> WhatToDo -> IO Bool @@ -199,7 +205,7 @@ doIt autoYes whatToDo = type InfoMessage = ProcessingFile FilePath | FileWouldChange FilePath - | ParseError FilePath (List (A.Located Syntax.Error)) + | ParseError FilePath (List (A.Located E.Error)) | JsonParseError FilePath String diff --git a/src/Terminal/Repl.elm b/src/Terminal/Repl.elm index 25bfda28d..0584953b8 100644 --- a/src/Terminal/Repl.elm +++ b/src/Terminal/Repl.elm @@ -383,7 +383,7 @@ attemptDeclOrExpr lines = case P.fromByteString declParser Tuple.pair src of Ok ( decl, _ ) -> case decl of - PD.Value _ (A.At _ (Src.Value (A.At _ name) _ _ _)) -> + PD.Value _ _ (A.At _ (Src.Value (A.At _ name) _ _ _)) -> ifDone lines (Decl name src) PD.Union _ (A.At _ (Src.Union (A.At _ name) _ _)) -> diff --git a/tests/Common/FormatTests.elm b/tests/Common/FormatTests.elm new file mode 100644 index 000000000..ec84c54ea --- /dev/null +++ b/tests/Common/FormatTests.elm @@ -0,0 +1,50 @@ +module Common.FormatTests exposing (suite) + +import Common.Format +import Compiler.Elm.Package as Pkg +import Compiler.Parse.Module as M +import Compiler.Parse.SyntaxVersion as SV +import Expect +import Test exposing (Test) + + +suite : Test +suite = + Test.describe "Common.Format.format" + [ Test.describe "fromByteString" + [ Test.test "Header" <| + \_ -> + Common.Format.format SV.Guida (M.Package Pkg.core) (generateModule defaultModule) + |> Expect.equal (Ok "module Main exposing (..)\n\n\nfn =\n ()\n") + ] + ] + + +type alias GenerateModuleConfig = + { header : String + , docs : String + , imports : List String + , infixes : List String + , declarations : List String + } + + +defaultModule : GenerateModuleConfig +defaultModule = + { header = "module Main exposing (..)" + , docs = "" + , imports = [] + , infixes = [] + , declarations = [ "fn = ()" ] + } + + +generateModule : GenerateModuleConfig -> String +generateModule { header, docs, imports, infixes, declarations } = + String.join "\n" + [ header + , docs + , String.join "\n" imports + , String.join "\n" infixes + , String.join "\n" declarations + ] diff --git a/tests/Parse/ModuleTests.elm b/tests/Parse/ModuleTests.elm new file mode 100644 index 000000000..226ff34db --- /dev/null +++ b/tests/Parse/ModuleTests.elm @@ -0,0 +1,66 @@ +module Parse.ModuleTests exposing (suite) + +import Compiler.AST.Source as S +import Compiler.Parse.Module as M +import Compiler.Parse.SyntaxVersion as SV +import Compiler.Reporting.Annotation as A +import Expect +import Test exposing (Test) + + +suite : Test +suite = + Test.describe "Parse.Module" + [ Test.describe "fromByteString" + [ Test.test "Hello!" <| + \_ -> + M.fromByteString SV.Elm M.Application """module Hello exposing (..) + +import Html exposing (text) + + +main = + text "Hello!" + """ + |> Expect.equal + (Ok + (S.Module + SV.Elm + (Just (A.at (A.Position 1 8) (A.Position 1 13) "Hello")) + (A.at (A.Position 1 23) (A.Position 1 27) S.Open) + (S.NoDocs (A.Region (A.Position 1 27) (A.Position 3 1)) []) + [ S.Import (A.at (A.Position 0 0) (A.Position 0 0) "Platform.Sub") (Just "Sub") (S.Explicit [ S.Upper (A.at (A.Position 0 0) (A.Position 0 0) "Sub") S.Private ]) + , S.Import (A.at (A.Position 0 0) (A.Position 0 0) "Platform.Cmd") (Just "Cmd") (S.Explicit [ S.Upper (A.at (A.Position 0 0) (A.Position 0 0) "Cmd") S.Private ]) + , S.Import (A.at (A.Position 0 0) (A.Position 0 0) "Platform") Nothing (S.Explicit [ S.Upper (A.at (A.Position 0 0) (A.Position 0 0) "Program") S.Private ]) + , S.Import (A.at (A.Position 0 0) (A.Position 0 0) "Tuple") Nothing (S.Explicit []) + , S.Import (A.at (A.Position 0 0) (A.Position 0 0) "Char") Nothing (S.Explicit [ S.Upper (A.at (A.Position 0 0) (A.Position 0 0) "Char") S.Private ]) + , S.Import (A.at (A.Position 0 0) (A.Position 0 0) "String") Nothing (S.Explicit [ S.Upper (A.at (A.Position 0 0) (A.Position 0 0) "String") S.Private ]) + , S.Import (A.at (A.Position 0 0) (A.Position 0 0) "Result") Nothing (S.Explicit [ S.Upper (A.at (A.Position 0 0) (A.Position 0 0) "Result") (S.Public (A.Region (A.Position 0 0) (A.Position 0 0))) ]) + , S.Import (A.at (A.Position 0 0) (A.Position 0 0) "Maybe") Nothing (S.Explicit [ S.Upper (A.at (A.Position 0 0) (A.Position 0 0) "Maybe") (S.Public (A.Region (A.Position 0 0) (A.Position 0 0))) ]) + , S.Import (A.at (A.Position 0 0) (A.Position 0 0) "List") Nothing (S.Explicit [ S.Operator (A.Region (A.Position 0 0) (A.Position 0 0)) "::" ]) + , S.Import (A.at (A.Position 0 0) (A.Position 0 0) "Debug") Nothing (S.Explicit []) + , S.Import (A.at (A.Position 0 0) (A.Position 0 0) "Basics") Nothing S.Open + , S.Import (A.at (A.Position 3 8) (A.Position 3 12) "Html") Nothing (S.Explicit [ S.Lower (A.at (A.Position 3 23) (A.Position 3 27) "text") ]) + ] + [ A.at (A.Position 6 1) + (A.Position 7 16) + (S.Value (A.at (A.Position 6 1) (A.Position 6 5) "main") + [] + (A.at (A.Position 7 3) + (A.Position 7 16) + (S.Call (A.at (A.Position 7 3) (A.Position 7 7) (S.Var S.LowVar "text")) + [ A.at (A.Position 7 8) (A.Position 7 16) (S.Str "Hello!") + ] + ) + ) + Nothing + ) + ] + [] + [] + [] + S.NoEffects + ) + ) + ] + ] diff --git a/tests/backwards-compatibility.test.js b/tests/backwards-compatibility.test.js index dfd136362..19af52f33 100644 --- a/tests/backwards-compatibility.test.js +++ b/tests/backwards-compatibility.test.js @@ -1,5 +1,5 @@ -const fs = require("fs"); -const path = require("path"); +const fs = require("node:fs"); +const path = require("node:path"); const childProcess = require("child_process"); const os = require("os"); const tmpDir = os.tmpdir(); diff --git a/tests/format.test.js b/tests/format.test.js new file mode 100644 index 000000000..248fcba42 --- /dev/null +++ b/tests/format.test.js @@ -0,0 +1,110 @@ +const fs = require("node:fs"); +const path = require("node:path"); +const childProcess = require("child_process"); +const os = require("os"); +const tmpDir = os.tmpdir(); + +const defaultModule = { + header: "module Main exposing (..)", + docs: "", + imports: [], + infixes: [], + declarations: ["fn = ()"] +} + +const examples = [ + // HEADERS + ["Header", [ + { title: "no effects", filename: "NoEffects", module: defaultModule }, + { title: "ports", filename: "Ports", module: { ...defaultModule, header: "port module Main exposing (..)" } }, + { title: "manager", filename: "Manager", module: { ...defaultModule, header: "effect module Main where { command = MyCmd } exposing (..)" } }, + { title: "single-line exposing", filename: "SingleLineExposing", module: { ...defaultModule, header: "module Main exposing (fn1, fn2)" } }, + { title: "multi-line exposing", filename: "MultiLineExposing", module: { ...defaultModule, header: "module Main exposing (fn1\n , fn2)" } }, + { title: "all multi-line", filename: "AllMultiLineHeader", module: { ...defaultModule, header: "module\n Main\n exposing\n (fn1\n , fn2\n )" } }, + ]], + // DOCS + ["Docs", [ + { title: "basic", filename: "BasicDocs", module: { ...defaultModule, docs: "{-| some documentation\n-}" } }, + ]], + // IMPORTS + ["Imports", [ + { title: "basic", filename: "BasicImports", module: { ...defaultModule, imports: ["import Module1"] } }, + { title: "alias", filename: "AliasImports", module: { ...defaultModule, imports: ["import Module1 as M"] } }, + { title: "exposing open", filename: "ExposingOpenImports", module: { ...defaultModule, imports: ["import Module1 exposing (..)"] } }, + { title: "exposing specific", filename: "ExposingSpecificImports", module: { ...defaultModule, imports: ["import Module1 exposing (fn1, fn2)"] } }, + { title: "all multi-line", filename: "AllMultiLineImports", module: { ...defaultModule, imports: ["import\n Module1\n exposing\n (fn1\n , fn2\n )"] } }, + ]], + // INFIXES + ["Infixes", [ + { title: "basic", filename: "BasicInfixes", module: { ...defaultModule, infixes: ["infix right 0 (<|) = apL"] } }, + ]], + // VALUE DECLARATIONS + ["Declarations", [ + { title: "unit type", filename: "UnitTypeDeclarations", module: { ...defaultModule, declarations: ["fn : ()\nfn = ()"] } }, + { title: "tuple type", filename: "TupleTypeDeclarations", module: { ...defaultModule, declarations: ["fn : ((), ())\nfn = ((), ())"] } }, + { title: "var type", filename: "VarTypeDeclarations", module: { ...defaultModule, declarations: ["fn : a -> a\nfn a = a"] } }, + { title: "unqualified type", filename: "UnqualifiedTypeDeclarations", module: { ...defaultModule, declarations: ["fn : List a -> List a\nfn list = list"] } }, + { title: "qualified type", filename: "QualifiedTypeDeclarations", module: { ...defaultModule, declarations: ["fn : Dict.Dict a -> Dict.Dict a\nfn dict = dict"] } }, + { title: "argument w/ parentheses type", filename: "ArgumentWithParenthesesTypeDeclarations", module: { ...defaultModule, declarations: ["fn : List (Maybe a)\nfn = []"] } }, + { title: "multiple declarations", filename: "MultipleDeclarations", module: { ...defaultModule, declarations: ["fn1 = ()\nfn2 = ()"] } }, + { title: "let block", filename: "LetBlockDeclarations", module: { ...defaultModule, declarations: ["fn = let _ = () in ()"] } }, + { title: "anonymous function", filename: "AnonymousFunctionDeclarations", module: { ...defaultModule, declarations: ["fn = \\_ -> ()"] } }, + { title: "anonymous function argument", filename: "AnonymousFunctionArgDeclarations", module: { ...defaultModule, declarations: ["fn = List.map (\\_ -> ())"] } }, + { title: "pipe operator", filename: "PipeOperatorDeclarations", module: { ...defaultModule, declarations: ["fn = \"\"\n |> String.trim"] } }, + { title: "list", filename: "ListDeclarations", module: { ...defaultModule, declarations: ["fn = [1,2,3]"] } }, + { title: "multi-line list", filename: "MultiLineListDeclarations", module: { ...defaultModule, declarations: ["fn = [\n 1,\n 2,3]"] } }, + { title: "argument w/ parentheses", filename: "ArgumentWithParenthesesDeclarations", module: { ...defaultModule, declarations: ["fn input = String.toInt (String.trim input)"] } }, + ]], + // UNION DECLARATIONS + ["Union", [ + { title: "single variant", filename: "SingleTypeUnionDeclarations", module: { ...defaultModule, declarations: ["type A = A"] } }, + ]], + // ALIAS DECLARATIONS + ["Alias", [ + { title: "integer", filename: "IntergerAliasDeclarations", module: { ...defaultModule, declarations: ["type alias A = Int"] } }, + { title: "single field record", filename: "SingleFieldRecordAliasDeclarations", module: { ...defaultModule, declarations: ["type alias A = { age: Int }"] } }, + { title: "multi-line record", filename: "MultiLineRecordAliasDeclarations", module: { ...defaultModule, declarations: ["type alias A = { age: Int\n , name: String }"] } }, + ]], + // PORT DECLARATIONS + ["Port", [ + { title: "in", filename: "InPortDeclarations", module: { ...defaultModule, declarations: ["port messageReceiver : (String -> msg) -> Sub msg"] } }, + { title: "out", filename: "OutPortDeclarations", module: { ...defaultModule, declarations: ["port sendMessage : String -> Cmd msg"] } }, + ]], + // COMMENTS + ["Comments", [ + { title: "single-line before header", filename: "SingleLineBeforeHeaderComments", module: { ...defaultModule, header: ["-- COMMENT\nmodule Main exposing (..)"] } }, + { title: "multi-line header", filename: "MultiLineHeaderComments", module: { ...defaultModule, header: ["module {- C1 -} Main {- C2 -} exposing {- C3 -} ({- C4 -}..{- C5 -})"] } }, + { title: "single-line header", filename: "SingleLineHeaderComments", module: { ...defaultModule, header: ["module -- C1\n Main -- C2\n exposing -- C3\n (..)"] } }, + { title: "single-line declaration", filename: "SingleLineDeclarationComments", module: { ...defaultModule, declarations: ["-- COMMENT", "fn = ()"] } }, + ]], +] + +describe("format", () => { + describe.each(examples)("%s", (example, modules) => { + test.each(modules)("$title", ({ filename, module }) => { + const moduleFilename = `${tmpDir}/GuidaTest${example}${filename}${process.pid}.Elm`; + const elmOutput = `${tmpDir}/GuidaTestElmOutput${example}${filename}${process.pid}.Elm`; + const guidaOutput = `${tmpDir}/GuidaTestGuidaOutput${example}${filename}${process.pid}.Elm`; + + fs.writeFileSync(moduleFilename, generateModule(module)); + + childProcess.execSync(`elm-format ${moduleFilename} --output ${elmOutput}`, { + cwd: path.join(__dirname, "..") + }); + + childProcess.execSync(`./bin/index.js format ${moduleFilename} --output ${guidaOutput}`, { + cwd: path.join(__dirname, "..") + }); + + expect(fs.readFileSync(guidaOutput).toString()).toBe(fs.readFileSync(elmOutput).toString()); + }); + }); +}); + +const generateModule = ({ header, docs, imports, infixes, declarations }) => { + return `${header} +${docs} +${imports.join("\n")} +${infixes.join("\n")} +${declarations.join("\n")}`; +} \ No newline at end of file