diff --git a/CHANGELOG.md b/CHANGELOG.md index 7542fa28b..844277e30 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +## main + +Format changes: + - (bug fix) Comments at the end of an `exposing` clause in `module` lines are now separated by a blank line to match the format of literal lists, records, and tuples. + - (invalid syntax) Record extensions with no fields now have only a single space before the closing `}`. + + ## 0.8.5 Feature changes: diff --git a/Shakefile.hs b/Shakefile.hs index 74d9d2afa..73bc22543 100644 --- a/Shakefile.hs +++ b/Shakefile.hs @@ -15,6 +15,10 @@ import Shakefiles.Extra main :: IO () main = do + shakefiles <- getDirectoryFilesIO "" + [ "Shakefile.hs" + , "Shakefiles//*.hs" + ] shakefilesHash <- getHashedShakeVersion [ "Shakefile.hs" ] shakeArgs shakeOptions{ shakeChange = ChangeModtimeAndDigest, @@ -40,7 +44,8 @@ main = do phony "build" $ need [ "elm-format" ] phony "elm-format" $ need [ elmFormat ] phony "unit-tests" $ need - [ "_build/cabal/elm-format-lib/test.ok" + [ "_build/cabal/avh4-lib/test.ok" + , "_build/cabal/elm-format-lib/test.ok" , "_build/cabal/elm-format-test-lib/test.ok" , "_build/cabal/elm-format/test.ok" ] diff --git a/Shakefiles/Haskell.hs b/Shakefiles/Haskell.hs index 7746fa688..7f30e7864 100644 --- a/Shakefiles/Haskell.hs +++ b/Shakefiles/Haskell.hs @@ -55,7 +55,7 @@ cabalProject name sourceFiles sourcePatterns deps testPatterns testDeps = need sourceFilesFromPatterns testFiles <- getDirectoryFiles "" testPatterns need testFiles - cmd_ "cabal" "v2-test" "-O0" (name ++ ":tests") "--test-show-details=streaming" + cmd_ "cabal" "v2-run" "-O0" "--enable-tests" (name ++ ":tests") "--" "-ffailed-examples" writeFile' out "" diff --git a/avh4-lib/avh4-lib.cabal b/avh4-lib/avh4-lib.cabal index ed6c388b1..2cdb0c18b 100644 --- a/avh4-lib/avh4-lib.cabal +++ b/avh4-lib/avh4-lib.cabal @@ -17,17 +17,33 @@ build-type: Simple common common-options - ghc-options: - -O2 -Wall -Wno-name-shadowing - default-language: Haskell2010 - + ghc-options: + -O2 + -Wall + -Wcompat + -Wredundant-constraints + -Wno-name-shadowing + -Werror=inaccessible-code + -Werror=missing-home-modules + -Werror=overflowed-literals + -Werror=overlapping-patterns default-extensions: + ApplicativeDo + DataKinds + DeriveFoldable DeriveFunctor - MultiParamTypeClasses + DeriveTraversable + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving LambdaCase + MultiParamTypeClasses OverloadedStrings + PolyKinds ScopedTypeVariables + TypeApplications + TypeFamilies hs-source-dirs: src @@ -39,7 +55,7 @@ common common-options base >= 4.15.0.0 && < 5, bimap >= 0.4.0 && < 0.5, binary >= 0.8.9.0 && < 0.9, - bytestring >= 0.11.1.0 && < 0.12, + bytestring >= 0.10.12.1 && < 0.12, containers >= 0.6.5.1 && < 0.7, directory >= 1.3.7.0 && < 2, filepath >= 1.4.2.1 && < 2, @@ -58,6 +74,7 @@ library CommandLine.World.IO Data.Coapplicative Data.Either.Extra + Data.Fix Data.Indexed Data.List.Extra Data.ReversedList @@ -71,7 +88,7 @@ test-suite al-tests type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: Tests.hs + main-is: Spec.hs other-modules: CommandLine.Filesystem @@ -79,6 +96,7 @@ test-suite al-tests CommandLine.World.IO Data.Coapplicative Data.Either.Extra + Data.Fix Data.Indexed Data.List.Extra Data.ReversedList @@ -87,13 +105,12 @@ test-suite al-tests Regex other-modules: - Data.List.ExtraTest - Data.Text.ExtraTest + Data.Either.ExtraSpec + Data.List.ExtraSpec + Data.Text.ExtraSpec build-depends: - tasty >= 1.2 && < 2, - tasty-hspec >= 1.1.5.1 && < 1.2, - tasty-hunit >= 0.10.0.1 && < 0.11 + hspec >= 2.7.10 && < 3 build-tool-depends: - tasty-discover:tasty-discover >= 4.2.1 && < 5 + hspec-discover:hspec-discover >= 2.7.10 && < 3 diff --git a/avh4-lib/src/CommandLine/World.hs b/avh4-lib/src/CommandLine/World.hs index 37522dd7e..f22230283 100644 --- a/avh4-lib/src/CommandLine/World.hs +++ b/avh4-lib/src/CommandLine/World.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} module CommandLine.World where import Prelude () diff --git a/avh4-lib/src/CommandLine/World/IO.hs b/avh4-lib/src/CommandLine/World/IO.hs index 2546575b7..367562497 100644 --- a/avh4-lib/src/CommandLine/World/IO.hs +++ b/avh4-lib/src/CommandLine/World/IO.hs @@ -1,5 +1,4 @@ {-# OPTIONS_GHC -Wno-orphans #-} -{-# LANGUAGE TypeFamilies #-} module CommandLine.World.IO where import Prelude () diff --git a/avh4-lib/src/Data/Either/Extra.hs b/avh4-lib/src/Data/Either/Extra.hs index f08c555a4..ecb0f18b0 100644 --- a/avh4-lib/src/Data/Either/Extra.hs +++ b/avh4-lib/src/Data/Either/Extra.hs @@ -1,7 +1,9 @@ -module Data.Either.Extra (collectErrors) where +module Data.Either.Extra (collectErrors, delimit) where import Prelude () import Relude +import qualified Data.ReversedList as ReversedList +import qualified Data.List as List collectErrors :: [Either l r] -> Either [l] [r] @@ -22,3 +24,46 @@ collectErrors list = Left ls in foldl' step (Right []) list + + +{-| Could possibly be replaced by +-} +delimit :: [Either delim a] -> ([a], [ (delim, [a]) ]) +delimit = + let + init = + ( ReversedList.empty + , Left () + ) + + step (cur, state) (Right b) = + ( ReversedList.push b cur + , state + ) + step (cur, state) (Left delim) = + ( ReversedList.empty + , case state of + Left () -> + Right + ( delim + , ReversedList.empty + , ReversedList.toList cur + ) + Right (prev, secs, sec1) -> + Right + ( delim + , ReversedList.push (prev,ReversedList.toList cur) secs + , sec1 + ) + ) + + done (cur, Left ()) = + ( ReversedList.toList cur + , [] + ) + done (cur, Right (delim, secs, sec1)) = + ( sec1 + , ReversedList.toList $ ReversedList.push (delim, ReversedList.toList cur) secs + ) + in + done . List.foldl' step init diff --git a/avh4-lib/src/Data/Fix.hs b/avh4-lib/src/Data/Fix.hs new file mode 100644 index 000000000..c99647c73 --- /dev/null +++ b/avh4-lib/src/Data/Fix.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Data.Fix where + +newtype Fix f = Fix { unFix :: f (Fix f) } + +deriving instance Show (f (Fix f)) => Show (Fix f) + + +cata :: + Functor f => + (f a -> a) + -> (Fix f -> a) +cata f = f . fmap (cata f) . unFix diff --git a/avh4-lib/src/Data/Indexed.hs b/avh4-lib/src/Data/Indexed.hs index b5d15ccbf..a6f79e6bf 100644 --- a/avh4-lib/src/Data/Indexed.hs +++ b/avh4-lib/src/Data/Indexed.hs @@ -1,52 +1,108 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} module Data.Indexed where import Data.Kind +import Control.Monad.Identity (Identity(..)) +import Data.Maybe (fromMaybe) +import Data.Functor.Const (Const(..)) -- Common typeclasses -class IFunctor (f :: (k -> Type) -> k -> Type) where - imap :: (forall i. a i -> b i) -> (forall i. f a i -> f b i) +type (~>) (f :: k -> Type) (g :: k -> Type) = + forall (i :: k). f i -> g i -class Foldable (t :: (k -> Type) -> k -> Type) where - foldMap :: Monoid m => (forall i. f i -> m) -> t f a -> m +class HFunctor (f :: (k -> Type) -> k -> Type) where + hmap :: (a ~> b) -> f a ~> f b + + +class HFoldable (t :: (k -> Type) -> k -> Type) where + hFoldMap :: Monoid m => (forall i. f i -> m) -> t f a -> m + hFold :: Monoid m => t (Const m) a -> m + hFold = hFoldMap getConst -- Recursion schemes -newtype Fix (ann :: Type -> Type) (f :: (k -> Type) -> k -> Type) (i :: k) - = Fix { unFix :: ann (f (Fix ann f) i) } +newtype Fix (f :: (k -> Type) -> k -> Type) (i :: k) + = Fix { unFix :: f (Fix f) i} -deriving instance Show (ann (f (Fix ann f) i)) => Show (Fix ann f i) -deriving instance Eq (ann (f (Fix ann f) i)) => Eq (Fix ann f i) -deriving instance Ord (ann (f (Fix ann f) i)) => Ord (Fix ann f i) +deriving instance Show (f (Fix f) i) => Show (Fix f i) +deriving instance Eq (f (Fix f) i) => Eq (Fix f i) +deriving instance Ord (f (Fix f) i) => Ord (Fix f i) -cata :: - Functor ann => - IFunctor f => - (forall i. ann (f a i) -> a i) - -> (forall i. Fix ann f i -> a i) -cata f = f . fmap (imap $ cata f) . unFix +fold :: HFunctor f => (f a ~> a) -> (Fix f ~> a) +fold f = f . hmap (fold f) . unFix +foldTransform :: HFunctor f => (forall i. f a i -> Either (Fix f i) (a i)) -> (Fix f ~> a) +foldTransform f = either (foldTransform f) id . f . hmap (foldTransform f) . unFix -ana :: - Functor ann => - IFunctor f => - (forall i. a i -> ann (f a i)) - -> (forall i. a i -> Fix ann f i) -ana f = Fix . fmap (imap $ ana f) . f +foldMaybeTransform :: HFunctor f => (forall i. f (Fix f) i -> Maybe (Fix f i)) -> (Fix f ~> Fix f) +foldMaybeTransform f orig = fromMaybe orig $ f $ hmap (foldMaybeTransform f) $ unFix orig + + +unfold :: HFunctor f => (a ~> f a) -> (a ~> Fix f) +unfold f = Fix . hmap (unfold f) . f +newtype Fix2 (ann :: Type -> Type) (f :: (k -> Type) -> k -> Type) (i :: k) + = Fix2 { unFix2 :: ann (f (Fix2 ann f) i) } + +deriving instance Show (ann (f (Fix2 ann f) i)) => Show (Fix2 ann f i) +deriving instance Eq (ann (f (Fix2 ann f) i)) => Eq (Fix2 ann f i) +deriving instance Ord (ann (f (Fix2 ann f) i)) => Ord (Fix2 ann f i) + +fold2 :: + HFunctor f => Functor ann => + (forall i. ann (f a i) -> a i) + -> (Fix2 ann f ~> a) +fold2 f = f . fmap (hmap $ fold2 f) . unFix2 + +foldConst2 :: + HFunctor f => Functor ann => + (forall i. ann (f (Const a) i) -> a) + -> (forall i. Fix2 ann f i -> a) +foldConst2 f = getConst . fold2 (Const . f) + +foldTransform2 :: + HFunctor f => Functor ann => + (forall i. ann (f a i) -> Either (Fix2 ann f i) (a i)) + -> (Fix2 ann f ~> a) +foldTransform2 f = + either (foldTransform2 f) id . f . fmap (hmap $ foldTransform2 f) . unFix2 + +foldMaybeTransform2 :: + HFunctor f => Functor ann => + (forall i. ann (f (Fix2 ann f) i) -> Maybe (Fix2 ann f i)) + -> (Fix2 ann f ~> Fix2 ann f) +foldMaybeTransform2 f orig = + fromMaybe orig $ f $ hmap (foldMaybeTransform2 f) <$> unFix2 orig + + +unfold2 :: + HFunctor f => Functor ann => + (forall i. a i -> ann (f a i)) + -> (a ~> Fix2 ann f) +unfold2 f = Fix2 . fmap (hmap $ unfold2 f) . f + convert :: - Functor ann1 => - IFunctor f => - (forall x. ann1 x -> ann2 x) -> - (forall i. Fix ann1 f i -> Fix ann2 f i) -convert f = cata (Fix . f) + HFunctor f => + Functor ann1 => + (ann1 ~> ann2) -> + (Fix2 ann1 f ~> Fix2 ann2 f) +convert f = fold2 (Fix2 . f) + +{-| Convenience function for applying a function that works with `Fix2` to a `Fix`. -} +fold2Identity :: + HFunctor f => HFunctor g => + (forall i. f (Fix2 Identity g) i -> Identity (g (Fix2 Identity g) i)) + -> (Fix f ~> Fix g) +fold2Identity f = + fold2 (Fix . runIdentity) + . fold2 (Fix2 . f . runIdentity) + . fold (Fix2 . Identity) diff --git a/avh4-lib/src/Data/ReversedList.hs b/avh4-lib/src/Data/ReversedList.hs index 7b12dfa57..58b042946 100644 --- a/avh4-lib/src/Data/ReversedList.hs +++ b/avh4-lib/src/Data/ReversedList.hs @@ -8,12 +8,20 @@ list that needs to be reversed in the termination case). newtype Reversed a = Reversed [a] +instance Show a => Show (Reversed a) where + show = show . toList + empty :: Reversed a empty = Reversed [] +singleton :: a -> Reversed a +singleton a = + Reversed [a] + + push :: a -> Reversed a -> Reversed a push a (Reversed list) = Reversed (a : list) diff --git a/avh4-lib/src/Elm/Utils.hs b/avh4-lib/src/Elm/Utils.hs index 81ed6992e..d764acc62 100644 --- a/avh4-lib/src/Elm/Utils.hs +++ b/avh4-lib/src/Elm/Utils.hs @@ -1,7 +1,6 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE FlexibleContexts #-} module Elm.Utils ( (|>), (<|), (>>) + , List , run, unwrappedRun , CommandError(..) ) where @@ -12,6 +11,9 @@ import System.Exit (ExitCode(ExitSuccess, ExitFailure)) import System.Process (readProcessWithExitCode) +type List = [] + + {-| Forward function application `x |> f == f x`. This function is useful for avoiding parenthesis and writing code in a more natural way. -} diff --git a/avh4-lib/test/Data/Either/ExtraSpec.hs b/avh4-lib/test/Data/Either/ExtraSpec.hs new file mode 100644 index 000000000..f76ae081d --- /dev/null +++ b/avh4-lib/test/Data/Either/ExtraSpec.hs @@ -0,0 +1,25 @@ +module Data.Either.ExtraSpec where + +import Data.Either.Extra +import Test.Hspec + + +spec :: Spec +spec = + describe "Data.Either.Extra" $ do + + describe "delimit" $ do + + it "groups the inputs" $ do + delimit + ([ Right 1 + , Left "A" + , Right 2, Right 3 + , Left "B" + ] :: [Either String Int]) + `shouldBe` + ( [ 1 ] + , [ ( "A", [2, 3]) + , ( "B", [] ) + ] + ) diff --git a/avh4-lib/test/Data/List/ExtraSpec.hs b/avh4-lib/test/Data/List/ExtraSpec.hs new file mode 100644 index 000000000..b281be752 --- /dev/null +++ b/avh4-lib/test/Data/List/ExtraSpec.hs @@ -0,0 +1,27 @@ +module Data.List.ExtraSpec where + +import Test.Hspec + +import Data.List.Extra + + +spec :: Spec +spec = describe "Util.List" $ do + describe "pairs" $ do + it "" $ pairs [1, 2, 3] `shouldBe` [(1,2), (2,3)] + it "empty" $ pairs ([] :: [Int]) `shouldBe` [] + it "single" $ pairs [1] `shouldBe` [] + describe "intersperseMap" $ do + it "" $ + intersperseMap (\a b -> [1000*a+b]) (\a -> a + 1) [ 20, 50, 70] + `shouldBe` [ 21, 20050, 51, 50070, 71 ] + it "empty" $ + intersperseMap (\a b -> []) id ([] :: [Int]) + `shouldBe` [] + describe "shift" $ do + it "" $ + shift "a" [(1,"b"), (2,"c")] + `shouldBe` ([("a",1), ("b",2)], "c") + it "empty" $ + shift "x" ([] :: [(Int,String)]) + `shouldBe` ([],"x") diff --git a/avh4-lib/test/Data/List/ExtraTest.hs b/avh4-lib/test/Data/List/ExtraTest.hs deleted file mode 100644 index b7a74ac0c..000000000 --- a/avh4-lib/test/Data/List/ExtraTest.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Data.List.ExtraTest where - -import Test.Tasty -import Test.Tasty.HUnit - -import Data.List.Extra - - -tests :: TestTree -tests = - testGroup "Util.List" - [ testGroup "pairs" - [ testCase "" $ assertEqual "" [(1,2), (2,3)] $ pairs [1, 2, 3] - , testCase "empty" $ assertEqual "" [] $ pairs ([] :: [Int]) - , testCase "single" $ assertEqual "" [] $ pairs [1] - ] - , testGroup "intersperseMap" - [ testCase "" $ assertEqual "" [ 21, 20050, 51, 50070, 71 ] $ intersperseMap (\a b -> [1000*a+b]) (\a -> a + 1) [ 20, 50, 70] - , testCase "empty" $ assertEqual "" [] $ intersperseMap (\a b -> []) id ([] :: [Int]) - ] - , testGroup "shift" - [ testCase "" $ assertEqual "" ([("a",1), ("b",2)], "c") $ shift "a" [(1,"b"), (2,"c")] - , testCase "" $ assertEqual "empty" ([],"x") $ shift "x" ([] :: [(Int,String)]) - ] - ] diff --git a/avh4-lib/test/Data/Text/ExtraSpec.hs b/avh4-lib/test/Data/Text/ExtraSpec.hs new file mode 100644 index 000000000..9dbb152d9 --- /dev/null +++ b/avh4-lib/test/Data/Text/ExtraSpec.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +module Data.Text.ExtraSpec (spec) where + +import Test.Hspec +import Data.Text.Extra + + +spec :: Spec +spec = describe "Data.Text.ExtraTest" $ do + it "when there is no span of the given character" $ + longestSpanOf '*' "stars exist only where you believe" + `shouldBe` NoSpan + it "when the given character is present" $ + longestSpanOf '*' "it's here -> * <-" + `shouldBe` Span 1 + it "only counts the longest span" $ + longestSpanOf '*' "it's here -> ** <-, not here: *" + `shouldBe` Span 2 diff --git a/avh4-lib/test/Data/Text/ExtraTest.hs b/avh4-lib/test/Data/Text/ExtraTest.hs deleted file mode 100644 index 8766f8894..000000000 --- a/avh4-lib/test/Data/Text/ExtraTest.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Data.Text.ExtraTest (test_tests) where - -import Elm.Utils ((|>)) - -import Test.Tasty -import Test.Tasty.HUnit - -import Data.Text.Extra - - -test_tests :: TestTree -test_tests = - testGroup "Data.Text.ExtraTest" - [ testCase "when there is no span of the given character" $ - longestSpanOf '*' "stars exist only where you believe" - |> assertEqual "" NoSpan - , testCase "when the given character is present" $ - longestSpanOf '*' "it's here -> * <-" - |> assertEqual "" (Span 1) - , testCase "only counts the longest span" $ - longestSpanOf '*' "it's here -> ** <-, not here: *" - |> assertEqual "" (Span 2) - ] diff --git a/avh4-lib/test/Spec.hs b/avh4-lib/test/Spec.hs new file mode 100644 index 000000000..a824f8c30 --- /dev/null +++ b/avh4-lib/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/avh4-lib/test/Tests.hs b/avh4-lib/test/Tests.hs deleted file mode 100644 index 70c55f52f..000000000 --- a/avh4-lib/test/Tests.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/cabal.project b/cabal.project index 0f888a1ee..2994ccaaa 100644 --- a/cabal.project +++ b/cabal.project @@ -8,6 +8,4 @@ with-compiler: ghc-9.0.1 constraints: -- ansi-terminal-0.11.1 has issues with Win32-2.10.* (which is packaged with ghc-9.0) - ansi-terminal == 0.11, - -- bytestring-0.11.2.0 makes aeson-2.0.2.0 fail to compile - bytestring == 0.11.1.0 + ansi-terminal == 0.11 diff --git a/cabal.project.freeze b/cabal.project.freeze index 85605f93a..c453b7d61 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -1,19 +1,18 @@ active-repositories: hackage.haskell.org:merge -constraints: any.Glob ==0.10.2, - any.HUnit ==1.6.2.0, +constraints: any.HUnit ==1.6.2.0, any.OneTuple ==0.3.1, any.QuickCheck ==2.14.2, QuickCheck -old-random +templatehaskell, any.StateVar ==1.2.2, - any.aeson ==2.0.2.0, - aeson -bytestring-builder -cffi +ordered-keymap, + any.aeson ==2.0.3.0, + aeson -cffi +ordered-keymap, any.ansi-terminal ==0.11, ansi-terminal -example, any.ansi-wl-pprint ==0.6.9, ansi-wl-pprint -example, any.array ==0.5.4.0, any.assoc ==1.0.2, - any.attoparsec ==0.14.3, + any.attoparsec ==0.14.4, attoparsec -developer, any.base ==4.15.0.0, any.base-compat ==0.12.1, @@ -23,10 +22,9 @@ constraints: any.Glob ==0.10.2, bifunctors +semigroups +tagged, any.bimap ==0.4.0, any.binary ==0.8.9.0, - any.bytestring ==0.11.1.0, - bytestring -integer-simple, + any.bytestring ==0.10.12.1, any.call-stack ==0.4.0, - any.clock ==0.8.2, + any.clock ==0.8.3, clock -llvm, any.cmark ==0.6, cmark -pkgconfig, @@ -50,22 +48,26 @@ constraints: any.Glob ==0.10.2, any.ghc-prim ==0.7.0, any.hashable ==1.3.5.0, hashable +integer-gmp -random-initial-seed, - any.hspec ==2.7.10, - any.hspec-core ==2.7.10, - any.hspec-discover ==2.7.10, + any.hspec ==2.9.2, + any.hspec-core ==2.9.2, + any.hspec-discover ==2.9.2, any.hspec-expectations ==0.8.2, any.hspec-golden ==0.1.0.3, any.indexed-traversable ==0.1.2, any.indexed-traversable-instances ==0.1.1, any.integer-logarithms ==1.0.3.1, integer-logarithms -check-bounds +integer-gmp, - any.logict ==0.7.0.3, + any.microlens ==0.4.12.0, + any.microlens-ghc ==0.4.13.1, + any.microlens-mtl ==0.2.0.1, + any.microlens-platform ==0.4.2.1, + any.microlens-th ==0.4.3.10, any.mtl ==2.2.2, any.optparse-applicative ==0.16.1.0, optparse-applicative +process, any.pretty ==1.1.3.6, any.primitive ==0.7.3.0, - any.process ==1.6.13.2, + any.process ==1.6.14.0, any.quickcheck-io ==0.2.0, any.random ==1.2.1, any.relude ==1.0.0.1, @@ -74,10 +76,9 @@ constraints: any.Glob ==0.10.2, scientific -bytestring-builder -integer-simple, any.semialign ==1.2.0.1, semialign +semigroupoids, - any.semigroupoids ==5.3.6, + any.semigroupoids ==5.3.7, semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, any.setenv ==0.1.1.3, - any.smallcheck ==1.2.1, any.split ==0.2.3.4, any.splitmix ==0.1.0.4, splitmix -optimised-mixer, @@ -86,17 +87,10 @@ constraints: any.Glob ==0.10.2, strict +assoc, any.tagged ==0.8.6.1, tagged +deepseq +transformers, - any.tasty ==1.4.2.1, - tasty +clock +unix, - any.tasty-discover ==4.2.2, - any.tasty-hspec ==1.1.6, - any.tasty-hunit ==0.10.0.3, - any.tasty-quickcheck ==0.10.2, - any.tasty-smallcheck ==0.8.2, any.template-haskell ==2.17.0.0, any.text ==1.2.5.0, text -developer, - any.text-short ==0.1.4, + any.text-short ==0.1.5, text-short -asserts, any.tf-random ==0.5, any.th-abstraction ==0.4.3.0, @@ -108,14 +102,11 @@ constraints: any.Glob ==0.10.2, any.transformers ==0.5.6.2, any.transformers-compat ==0.7.1, transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, - any.unbounded-delays ==0.1.1.1, any.unix ==2.7.2.2, - any.unordered-containers ==0.2.16.0, + any.unordered-containers ==0.2.18.0, unordered-containers -debug, any.uuid-types ==1.0.5, any.vector ==0.12.3.1, vector +boundschecks -internalchecks -unsafechecks -wall, - any.wcwidth ==0.0.2, - wcwidth -cli +split-base, any.witherable ==0.4.2 -index-state: hackage.haskell.org 2021-12-11T03:42:51Z +index-state: hackage.haskell.org 2022-04-22T03:04:38Z diff --git a/elm-format-lib/elm-format-lib.cabal b/elm-format-lib/elm-format-lib.cabal index 2be21921c..e5fb06f03 100644 --- a/elm-format-lib/elm-format-lib.cabal +++ b/elm-format-lib/elm-format-lib.cabal @@ -17,18 +17,33 @@ build-type: Simple common common-options - ghc-options: - -O2 -Wall -Wno-name-shadowing - default-language: Haskell2010 - + ghc-options: + -O2 + -Wall + -Wcompat + -Wredundant-constraints + -Wno-name-shadowing + -Werror=inaccessible-code + -Werror=missing-home-modules + -Werror=overflowed-literals + -Werror=overlapping-patterns default-extensions: + ApplicativeDo + DataKinds + DeriveFoldable DeriveFunctor - MultiParamTypeClasses + DeriveTraversable + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving LambdaCase + MultiParamTypeClasses OverloadedStrings + PolyKinds ScopedTypeVariables - FlexibleInstances + TypeApplications + TypeFamilies hs-source-dirs: src @@ -51,6 +66,7 @@ common common-options ElmFormat.AST.PublicAST.Type ElmFormat.Render.Box ElmFormat.Render.ElmStructure + Indent Parse.Binop Parse.Comments Parse.Common @@ -72,14 +88,14 @@ common common-options Parse.Whitespace build-depends: - aeson >= 2.0.1.0 && < 2.1, + aeson >= 2.0.3.0 && < 2.1, ansi-terminal >= 0.11 && < 0.12, ansi-wl-pprint >= 0.6.9 && < 0.7, array >= 0.5.4.0 && < 0.6, base >= 4.15.0.0 && < 5, bimap >= 0.4.0 && < 0.5, binary >= 0.8.9.0 && < 0.9, - bytestring >= 0.11.1.0 && < 0.12, + bytestring >= 0.10.12.1 && < 0.12, containers >= 0.6.5.1 && < 0.7, directory >= 1.3.7.0 && < 2, filepath >= 1.4.2.1 && < 2, @@ -97,19 +113,19 @@ library import: common-options exposed-modules: - AST.Listing AST.MatchReferences - AST.Module AST.Structure AST.V0_16 CommandLine.InfoFormatter CommandLine.Program CommandLine.ResolveFiles CommandLine.TransformFiles + ElmFormat.AST.TransformChain ElmFormat.AST.PublicAST ElmFormat.AST.Shared ElmFormat.ImportInfo ElmFormat.KnownContents + ElmFormat.Normalize ElmFormat.Parse ElmFormat.Render.Markdown ElmFormat.Render.Text @@ -125,19 +141,19 @@ test-suite efl-tests type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: Tests.hs + main-is: Spec.hs other-modules: - AST.Listing AST.MatchReferences - AST.Module AST.Structure AST.V0_16 CommandLine.InfoFormatter + ElmFormat.AST.TransformChain ElmFormat.AST.PublicAST ElmFormat.AST.Shared ElmFormat.ImportInfo ElmFormat.KnownContents + ElmFormat.Normalize ElmFormat.Parse ElmFormat.Render.Markdown ElmFormat.Render.Text @@ -148,26 +164,26 @@ test-suite efl-tests Reporting.Result other-modules: - AST.MatchReferencesTest - BoxTest - ElmFormat.AST.BinaryOperatorPrecedenceTest - ElmFormat.ImportInfoTest - ElmFormat.Render.ElmStructureTest - Parse.ExpressionTest - Parse.HelpersTest - Parse.LiteralTest - Parse.PatternTest + AST.MatchReferencesSpec + BoxSpec + ElmFormat.AST.BinaryOperatorPrecedenceSpec + ElmFormat.ImportInfoSpec + ElmFormat.NormalizeSpec + ElmFormat.Render.ElmStructureSpec + IndentSpec + Parse.ExpressionSpec + Parse.HelpersSpec + Parse.LiteralSpec + Parse.PatternSpec Parse.TestHelpers - Parse.TestHelpersTest - Parse.TypeTest + Parse.TestHelpersSpec + Parse.TypeSpec build-depends: split >= 0.2.3.4 && < 0.3, - tasty >= 1.2 && < 2, - tasty-hspec >= 1.1.5.1 && < 1.2, - tasty-hunit >= 0.10.0.1 && < 0.11, + hspec >= 2.7.10 && < 3, avh4-lib, elm-format-test-lib build-tool-depends: - tasty-discover:tasty-discover >= 4.2.1 && < 5 + hspec-discover:hspec-discover >= 2.7.10 && < 3 diff --git a/elm-format-lib/src/AST/Listing.hs b/elm-format-lib/src/AST/Listing.hs deleted file mode 100644 index 49faf7262..000000000 --- a/elm-format-lib/src/AST/Listing.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DataKinds #-} -module AST.Listing where - -import AST.V0_16 -import Data.Map.Strict - - --- | A listing of values. Something like (a,b,c) or (..) or (a,b,..) -data Listing a - = ExplicitListing a Bool - | OpenListing (C2 'BeforeTerm 'AfterTerm ()) - | ClosedListing - deriving (Eq, Ord, Show) -- TODO: is Ord needed? - -mergeListing :: (a -> a -> a) -> Listing a -> Listing a -> Listing a -mergeListing merge left right = - case (left, right) of - (ClosedListing, ClosedListing) -> ClosedListing - (ClosedListing, OpenListing comments) -> OpenListing comments - (OpenListing comments, ClosedListing) -> OpenListing comments - (OpenListing (C (pre1, post1) ()), OpenListing (C (pre2, post2) ())) -> OpenListing (C (pre1 ++ pre2, post1 ++ post2) ()) - (ClosedListing, ExplicitListing a multiline) -> ExplicitListing a multiline - (ExplicitListing a multiline, ClosedListing) -> ExplicitListing a multiline - (OpenListing comments, ExplicitListing _a _multiline) -> OpenListing comments - (ExplicitListing _a _multiline, OpenListing comments) -> OpenListing comments - (ExplicitListing a multiline1, ExplicitListing b multiline2) -> ExplicitListing (merge a b) (multiline1 || multiline2) - - -type CommentedMap k v = - Map k (C2 'BeforeTerm 'AfterTerm v) - -mergeCommentedMap :: Ord k => (v -> v -> v) -> CommentedMap k v -> CommentedMap k v -> CommentedMap k v -mergeCommentedMap merge left right = - let - merge' (C (pre1, post1) a) (C (pre2, post2) b) = - C (pre1 ++ pre2, post1 ++ post2) (merge a b) - in - unionWith merge' left right - - --- | A value that can be imported or exported -data Value - = Value !LowercaseIdentifier - | OpValue SymbolIdentifier - | Union (C1 'AfterTerm UppercaseIdentifier) (Listing (CommentedMap UppercaseIdentifier ())) - deriving (Eq, Ord, Show) -- TODO: is Ord needed? diff --git a/elm-format-lib/src/AST/MatchReferences.hs b/elm-format-lib/src/AST/MatchReferences.hs index 24d48778e..9599b06d6 100644 --- a/elm-format-lib/src/AST/MatchReferences.hs +++ b/elm-format-lib/src/AST/MatchReferences.hs @@ -11,6 +11,7 @@ import qualified Data.Map.Strict as Dict import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified ElmFormat.ImportInfo as ImportInfo +import qualified Data.Indexed as I data MatchedNamespace t @@ -31,8 +32,8 @@ fromMatched empty (UnmatchedUnqualified _) = empty matchReferences :: (Coapplicative annf, Ord u) => ImportInfo [u] - -> ASTNS annf [u] kind - -> ASTNS annf (MatchedNamespace [u]) kind + -> I.Fix2 annf (ASTNS [u]) kind + -> I.Fix2 annf (ASTNS (MatchedNamespace [u])) kind matchReferences importInfo = let aliases = Bimap.toMap $ ImportInfo._aliases importInfo @@ -86,8 +87,8 @@ matchReferences importInfo = applyReferences :: (Coapplicative annf, Ord u) => ImportInfo [u] - -> ASTNS annf (MatchedNamespace [u]) kind - -> ASTNS annf [u] kind + -> I.Fix2 annf (ASTNS (MatchedNamespace [u])) kind + -> I.Fix2 annf (ASTNS [u]) kind applyReferences importInfo = let aliases = Bimap.toMapR $ ImportInfo._aliases importInfo diff --git a/elm-format-lib/src/AST/Module.hs b/elm-format-lib/src/AST/Module.hs deleted file mode 100644 index 7fd6868bf..000000000 --- a/elm-format-lib/src/AST/Module.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DataKinds #-} - -module AST.Module - ( Module(..), Header(..), SourceTag(..), SourceSettings - , UserImport, ImportMethod(..) - , DetailedListing(..) - , defaultHeader - ) where - -import AST.Listing (Listing) -import qualified AST.Listing as Listing -import qualified Cheapskate.Types as Markdown -import Data.Map.Strict (Map) -import qualified Reporting.Annotation as A -import AST.V0_16 - - --- MODULES - - -data Module ns body = - Module - { initialComments :: Comments - , header :: Maybe Header - , docs :: A.Located (Maybe Markdown.Blocks) - , imports :: C1 'BeforeTerm (Map ns (C1 'BeforeTerm ImportMethod)) - , body :: body - } - deriving (Eq, Show, Functor) - - --- HEADERS - -data SourceTag - = Normal - | Effect Comments - | Port Comments - deriving (Eq, Show) - - -{-| Basic info needed to identify modules and determine dependencies. -} -data Header = Header - { srcTag :: SourceTag - , name :: C2 'BeforeTerm 'AfterTerm [UppercaseIdentifier] - , moduleSettings :: Maybe (C2 'BeforeSeparator 'AfterSeparator SourceSettings) - , exports :: Maybe (C2 'BeforeSeparator 'AfterSeparator (Listing DetailedListing)) - } - deriving (Eq, Show) - - -defaultHeader :: Header -defaultHeader = - Header - Normal - (C ([], []) [UppercaseIdentifier "Main"]) - Nothing - Nothing - - -data DetailedListing = DetailedListing - { values :: Listing.CommentedMap LowercaseIdentifier () - , operators :: Listing.CommentedMap SymbolIdentifier () - , types :: Listing.CommentedMap UppercaseIdentifier (C1 'BeforeTerm (Listing (Listing.CommentedMap UppercaseIdentifier ()))) - } - deriving (Eq, Show) - -instance Semigroup DetailedListing where - (DetailedListing av ao at) <> (DetailedListing bv bo bt) = DetailedListing (av <> bv) (ao <> bo) (at <> bt) - -instance Monoid DetailedListing where - mempty = DetailedListing mempty mempty mempty - - -type SourceSettings = - [ ( C2 'BeforeTerm 'AfterTerm LowercaseIdentifier - , C2 'BeforeTerm 'AfterTerm UppercaseIdentifier - ) - ] - --- IMPORTs - -type UserImport - = (C1 'BeforeTerm [UppercaseIdentifier], ImportMethod) - - -data ImportMethod = ImportMethod - { alias :: Maybe (C2 'BeforeSeparator 'AfterSeparator UppercaseIdentifier) - , exposedVars :: C2 'BeforeSeparator 'AfterSeparator (Listing DetailedListing) - } - deriving (Eq, Show) diff --git a/elm-format-lib/src/AST/Structure.hs b/elm-format-lib/src/AST/Structure.hs index 4c9833bf7..59310911a 100644 --- a/elm-format-lib/src/AST/Structure.hs +++ b/elm-format-lib/src/AST/Structure.hs @@ -1,152 +1,45 @@ {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} module AST.Structure - ( FixAST, ASTNS, ASTNS1 - , foldReferences + ( ASTNS, ASTNS1 , bottomUpReferences , mapNs ) where -import Data.Coapplicative -import Data.Foldable (fold) -import Data.Functor.Const import AST.V0_16 import qualified Data.Indexed as I --- FixAST :: (Type -> Type) -> Type -> Type -> Type -> NodeKind -> Type -type FixAST annf typeRef ctorRef varRef = - I.Fix annf (AST typeRef ctorRef varRef) +type ASTNS ns = + AST (VariableNamespace ns) --- ASTNS :: (Type -> Type) -> Type -> NodeKind -> Type -type ASTNS annf ns = - FixAST annf (ns, UppercaseIdentifier) (ns, UppercaseIdentifier) (Ref ns) --- This is the same as ASTNS, but with the first level unFix'ed -- ASTNS1 :: (Type -> Type) -> Type -> NodeKind -> Type type ASTNS1 annf ns = - AST - (ns, UppercaseIdentifier) - (ns, UppercaseIdentifier) - (Ref ns) - (ASTNS annf ns) + ASTNS ns (I.Fix2 annf (ASTNS ns)) bottomUpReferences :: (Functor annf) => - (typeRef1 -> typeRef2) - -> (ctorRef1 -> ctorRef2) - -> (varRef1 -> varRef2) + (TypeRef p1 -> TypeRef p2) + -> (CtorRef p1 -> CtorRef p2) + -> (VarRef p1 -> VarRef p2) -> (forall kind. - FixAST annf typeRef1 ctorRef1 varRef1 kind - -> FixAST annf typeRef2 ctorRef2 varRef2 kind + I.Fix2 annf (AST p1) kind + -> I.Fix2 annf (AST p2) kind ) bottomUpReferences ftr fcr fvr = - I.cata (I.Fix . fmap (mapAll ftr fcr fvr id)) - - -foldReferences :: - forall a annf typeRef ctorRef varRef kind. - (Monoid a, Coapplicative annf) => - (typeRef -> a) -> (ctorRef -> a) -> (varRef -> a) - -> FixAST annf typeRef ctorRef varRef kind -> a -foldReferences ftype fctor fvar = - getConst . I.cata (foldNode . extract) - where - -- This is kinda confusing, but we use the Const type constructor to merge all the different NodeKinds into a single type `a` - -- See http://www.timphilipwilliams.com/posts/2013-01-16-fixing-gadts.html for relevant details. - foldNode :: forall kind'. AST typeRef ctorRef varRef (Const a) kind' -> Const a kind' - foldNode = \case - TopLevel tls -> Const $ foldMap (foldMap getConst) tls - - -- Declarations - Definition name args _ e -> Const (getConst name <> foldMap (getConst . extract) args <> getConst e) - TypeAnnotation _ t -> Const (getConst $ extract t) - CommonDeclaration d -> Const $ getConst d - Datatype _ ctors -> Const (foldMap (getConst . fold) ctors) - TypeAlias _ _ t -> Const (getConst $ extract t) - PortAnnotation _ _ t -> Const (getConst t) - PortDefinition_until_0_16 _ _ e -> Const (getConst e) - Fixity_until_0_18 _ _ _ _ name -> Const (fvar name) - Fixity _ _ _ _ -> mempty - - -- Expressions - Unit _ -> mempty - Literal _ -> mempty - VarExpr var -> Const $ fvar var - App first rest _ -> first <> mconcat (fmap extract rest) - Unary _ e -> e - Binops first ops _ -> Const (getConst first <> foldMap foldBinopsClause ops) - Parens e -> extract e - ExplicitList terms _ _ -> fold terms - Range left right _ -> extract left <> extract right - Tuple terms _ -> mconcat $ fmap extract terms - TupleFunction _ -> mempty - Record _ fields _ _ -> foldMap (extract . _value) fields - Access e _ -> e - AccessFunction _ -> mempty - Lambda args _ e _ -> Const (foldMap (getConst . extract) args <> getConst e) - If cond elsifs els -> Const (foldIfClause cond <> foldMap (foldIfClause . extract) elsifs <> getConst (extract els)) - Let defs _ e -> Const (foldMap getConst defs <> getConst e) - LetCommonDeclaration d -> Const $ getConst d - LetComment _ -> mempty - Case (cond, _) branches -> Const (getConst (extract cond) <> foldMap getConst branches) - CaseBranch _ _ _ p e -> Const (getConst p <> getConst e) - GLShader _ -> mempty - - -- Patterns - Anything -> mempty - UnitPattern _ -> mempty - LiteralPattern _ -> mempty - VarPattern _ -> mempty - OpPattern _ -> mempty - DataPattern ctor args -> Const (fctor ctor <> foldMap (getConst . extract) args) - PatternParens p -> extract p - TuplePattern terms -> foldMap extract terms - EmptyListPattern _ -> mempty - ListPattern terms -> foldMap extract terms - ConsPattern first rest -> extract first <> fold rest - EmptyRecordPattern _ -> mempty - RecordPattern _ -> mempty - Alias p _ -> extract p - - -- Types - UnitType _ -> mempty - TypeVariable _ -> mempty - TypeConstruction name args _ -> Const (foldTypeConstructor name <> foldMap (getConst . extract) args) - TypeParens typ -> extract typ - TupleType terms _ -> foldMap extract terms - RecordType _ fields _ _ -> foldMap (extract . _value) fields - FunctionType first rest _ -> extract first <> fold rest - - foldTypeConstructor :: TypeConstructor typeRef -> a - foldTypeConstructor = \case - NamedConstructor name -> ftype name - TupleConstructor _ -> mempty - - foldBinopsClause :: BinopsClause varRef (Const a 'ExpressionNK) -> a - foldBinopsClause = \case - BinopsClause _ op _ e -> fvar op <> getConst e - - foldIfClause :: IfClause (Const a 'ExpressionNK) -> a - foldIfClause = \case - IfClause cond els -> getConst (extract cond) <> getConst (extract els) + I.fold2 (I.Fix2 . fmap (mapAll ftr fcr fvr id)) mapNs :: Functor annf => (ns1 -> ns2) -> (forall kind. - ASTNS annf ns1 kind - -> ASTNS annf ns2 kind + I.Fix2 annf (ASTNS ns1) kind + -> I.Fix2 annf (ASTNS ns2) kind ) mapNs f = let diff --git a/elm-format-lib/src/AST/V0_16.hs b/elm-format-lib/src/AST/V0_16.hs index 3371e44ae..74cf443af 100644 --- a/elm-format-lib/src/AST/V0_16.hs +++ b/elm-format-lib/src/AST/V0_16.hs @@ -1,10 +1,8 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module AST.V0_16 (module AST.V0_16, module ElmFormat.AST.Shared) where @@ -19,6 +17,10 @@ import qualified Cheapskate.Types as Markdown import ElmFormat.AST.Shared import qualified Data.Maybe as Maybe import Data.Text (Text) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Bifoldable (Bifoldable(..)) newtype ForceMultiline = @@ -65,6 +67,18 @@ class AsCommentedList f where fromCommentedList :: List (CommentsFor f a) -> Either Text (f a) +type CommentedMap k v = + Map k (C2 'BeforeTerm 'AfterTerm v) + +mergeCommentedMap :: Ord k => (v -> v -> v) -> CommentedMap k v -> CommentedMap k v -> CommentedMap k v +mergeCommentedMap merge left right = + let + merge' (C (pre1, post1) a) (C (pre2, post2) b) = + C (pre1 ++ pre2, post1 ++ post2) (merge a b) + in + Map.unionWith merge' left right + + {-| This represents a list of things separated by comments. Currently, the first item will never have leading comments. @@ -135,10 +149,7 @@ TODO: this should be replaced with (Sequence a) -} data OpenCommentedList a = OpenCommentedList [C2Eol 'BeforeTerm 'AfterTerm a] (C1Eol 'BeforeTerm a) - deriving (Eq, Show, Functor) - -instance Foldable OpenCommentedList where - foldMap f (OpenCommentedList rest last) = foldMap (f . extract) rest <> (f . extract) last + deriving (Eq, Show, Functor, Foldable) instance AsCommentedList OpenCommentedList where type CommentsFor OpenCommentedList = C2Eol 'BeforeTerm 'AfterTerm @@ -180,11 +191,11 @@ data Pair key value = , _value :: C1 'BeforeTerm value , forceMultiline :: ForceMultiline } - deriving (Show, Eq, Functor) + deriving (Show, Eq, Functor, Foldable) -mapPair :: (a1 -> a2) -> (b1 -> b2) -> Pair a1 b1 -> Pair a2 b2 -mapPair fa fb (Pair k v fm) = - Pair (fa <$> k) (fb <$> v) fm +instance Bifunctor Pair where + bimap fa fb (Pair a b fm) = + Pair (fa <$> a) (fb <$> b) fm data Multiline @@ -217,15 +228,74 @@ assocToString assoc = data NameWithArgs name arg = NameWithArgs name [C1 'BeforeTerm arg] - deriving (Eq, Show, Functor) -instance Foldable (NameWithArgs name) where - foldMap f (NameWithArgs _ args) = foldMap (f . extract) args + deriving (Eq, Show, Functor, Foldable) + +instance Bifunctor NameWithArgs where + bimap fname farg (NameWithArgs name args) = + NameWithArgs (fname name) (fmap farg <$> args) + + +data SourceTag + = Normal + | Effect Comments + | Port Comments + deriving (Eq, Show) + + +type SourceSettings = + [ ( C2 'BeforeTerm 'AfterTerm LowercaseIdentifier + , C2 'BeforeTerm 'AfterTerm UppercaseIdentifier + ) + ] + + +-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..) +data Listing a + = ExplicitListing a Bool + | OpenListing (C2 'BeforeTerm 'AfterTerm ()) + | ClosedListing + deriving (Eq, Ord, Show, Functor) -- TODO: is Ord needed? + +mergeListing :: (a -> a -> a) -> Listing a -> Listing a -> Listing a +mergeListing merge left right = + case (left, right) of + (ClosedListing, ClosedListing) -> ClosedListing + (ClosedListing, OpenListing comments) -> OpenListing comments + (OpenListing comments, ClosedListing) -> OpenListing comments + (OpenListing (C (pre1, post1) ()), OpenListing (C (pre2, post2) ())) -> OpenListing (C (pre1 ++ pre2, post1 ++ post2) ()) + (ClosedListing, ExplicitListing a multiline) -> ExplicitListing a multiline + (ExplicitListing a multiline, ClosedListing) -> ExplicitListing a multiline + (OpenListing comments, ExplicitListing _a _multiline) -> OpenListing comments + (ExplicitListing _a _multiline, OpenListing comments) -> OpenListing comments + (ExplicitListing a multiline1, ExplicitListing b multiline2) -> ExplicitListing (merge a b) (multiline1 || multiline2) + + +-- | A value that can be imported or exported +data ListingValue + = Value !LowercaseIdentifier + | OpValue SymbolIdentifier + | Union (C1 'AfterTerm UppercaseIdentifier) (Listing (CommentedMap UppercaseIdentifier ())) + deriving (Eq, Ord, Show) -- TODO: is Ord needed? + + +data DetailedListing = DetailedListing + { values :: CommentedMap LowercaseIdentifier () + , operators :: CommentedMap SymbolIdentifier () + , types :: CommentedMap UppercaseIdentifier (C1 'BeforeTerm (Listing (CommentedMap UppercaseIdentifier ()))) + } + deriving (Eq, Show) + +instance Semigroup DetailedListing where + (DetailedListing av ao at) <> (DetailedListing bv bo bt) = DetailedListing (av <> bv) (ao <> bo) (at <> bt) + +instance Monoid DetailedListing where + mempty = DetailedListing mempty mempty mempty data TypeConstructor ctorRef = NamedConstructor ctorRef | TupleConstructor Int -- will be 2 or greater, indicating the number of elements in the tuple - deriving (Eq, Show, Functor) + deriving (Eq, Show, Functor, Foldable) data BinopsClause varRef expr = @@ -236,22 +306,20 @@ instance Bifunctor BinopsClause where bimap fvr fe = \case BinopsClause c1 vr c2 e -> BinopsClause c1 (fvr vr) c2 (fe e) +instance Bifoldable BinopsClause where + bifoldMap fa fb (BinopsClause _ a _ b) = fa a <> fb b + data IfClause e = IfClause (C2 'BeforeTerm 'AfterTerm e) (C2 'BeforeTerm 'AfterTerm e) - deriving (Eq, Show, Functor) + deriving (Eq, Show, Functor, Foldable) data TopLevelStructure a = DocComment Markdown.Blocks | BodyComment Comment | Entry a - deriving (Eq, Show, Functor) - -instance Foldable TopLevelStructure where - foldMap _ (DocComment _) = mempty - foldMap _ (BodyComment _) = mempty - foldMap f (Entry a) = f a + deriving (Eq, Show, Functor, Foldable) data LocalName @@ -262,7 +330,14 @@ data LocalName data NodeKind - = TopLevelNK + = ModuleNK + | ImportMethodNK + | ModuleListingNK + | ModuleHeaderNK + | ModuleBodyNK + | TypeRefNK + | CtorRefNK + | VarRefNK | CommonDeclarationNK | TopLevelDeclarationNK | ExpressionNK @@ -272,11 +347,58 @@ data NodeKind | TypeNK -data AST typeRef ctorRef varRef (getType :: NodeKind -> Type) (kind :: NodeKind) where +class ASTParameters p where + type TypeRef p :: Type + type CtorRef p :: Type + type VarRef p :: Type + +data VariableNamespace (ns :: Type) +instance ASTParameters (VariableNamespace ns) where + type TypeRef (VariableNamespace ns) = (ns, UppercaseIdentifier) + type CtorRef (VariableNamespace ns) = (ns, UppercaseIdentifier) + type VarRef (VariableNamespace ns) = Ref ns + - TopLevel :: +data AST p (getType :: NodeKind -> Type) (kind :: NodeKind) where + + -- + -- Singletons + -- + + TypeRef_ :: TypeRef p -> AST p getType 'TypeRefNK + CtorRef_ :: CtorRef p -> AST p getType 'CtorRefNK + VarRef_ :: VarRef p -> AST p getType 'VarRefNK + + -- + -- Module + -- + + Module :: + { initialComments :: Comments + , header :: Maybe (getType 'ModuleHeaderNK) + , docs :: Maybe Markdown.Blocks + , imports :: C1 'BeforeTerm (Map [UppercaseIdentifier] (C1 'BeforeTerm (getType 'ImportMethodNK))) + , moduleBody :: getType 'ModuleBodyNK + } + -> AST p getType 'ModuleNK + ImportMethod :: + { alias :: Maybe (C2 'BeforeSeparator 'AfterSeparator UppercaseIdentifier) + , exposedVars :: C2 'BeforeSeparator 'AfterSeparator (getType 'ModuleListingNK) + } + -> AST p getType 'ImportMethodNK + ModuleListing :: + Listing DetailedListing + -> AST p getType 'ModuleListingNK + ModuleHeader :: + { srcTag :: SourceTag + , name :: C2 'BeforeTerm 'AfterTerm [UppercaseIdentifier] + , moduleSettings :: Maybe (C2 'BeforeSeparator 'AfterSeparator SourceSettings) + , exports :: Maybe (C2 'BeforeSeparator 'AfterSeparator (getType 'ModuleListingNK)) + } + -> AST p getType 'ModuleHeaderNK + ModuleBody :: [TopLevelStructure (getType 'TopLevelDeclarationNK)] - -> AST typeRef ctorRef varRef getType 'TopLevelNK + -> AST p getType 'ModuleBodyNK -- -- Declarations @@ -287,99 +409,92 @@ data AST typeRef ctorRef varRef (getType :: NodeKind -> Type) (kind :: NodeKind) -> [C1 'BeforeTerm (getType 'PatternNK)] -> Comments -> getType 'ExpressionNK - -> AST typeRef ctorRef varRef getType 'CommonDeclarationNK + -> AST p getType 'CommonDeclarationNK TypeAnnotation :: C1 'AfterTerm (Ref ()) -> C1 'BeforeTerm (getType 'TypeNK) - -> AST typeRef ctorRef varRef getType 'CommonDeclarationNK + -> AST p getType 'CommonDeclarationNK CommonDeclaration :: getType 'CommonDeclarationNK - -> AST typeRef ctorRef varRef getType 'TopLevelDeclarationNK + -> AST p getType 'TopLevelDeclarationNK Datatype :: { nameWithArgs :: C2 'BeforeTerm 'AfterTerm (NameWithArgs UppercaseIdentifier LowercaseIdentifier) , tags :: OpenCommentedList (NameWithArgs UppercaseIdentifier (getType 'TypeNK)) } - -> AST typeRef ctorRef varRef getType 'TopLevelDeclarationNK + -> AST p getType 'TopLevelDeclarationNK TypeAlias :: Comments -> C2 'BeforeTerm 'AfterTerm (NameWithArgs UppercaseIdentifier LowercaseIdentifier) -> C1 'BeforeTerm (getType 'TypeNK) - -> AST typeRef ctorRef varRef getType 'TopLevelDeclarationNK + -> AST p getType 'TopLevelDeclarationNK PortAnnotation :: C2 'BeforeTerm 'AfterTerm LowercaseIdentifier -> Comments -> getType 'TypeNK - -> AST typeRef ctorRef varRef getType 'TopLevelDeclarationNK + -> AST p getType 'TopLevelDeclarationNK PortDefinition_until_0_16 :: C2 'BeforeTerm 'AfterTerm LowercaseIdentifier -> Comments -> getType 'ExpressionNK - -> AST typeRef ctorRef varRef getType 'TopLevelDeclarationNK + -> AST p getType 'TopLevelDeclarationNK Fixity_until_0_18 :: Assoc -> Comments -> Int -> Comments - -> varRef - -> AST typeRef ctorRef varRef getType 'TopLevelDeclarationNK + -> getType 'VarRefNK + -> AST p getType 'TopLevelDeclarationNK Fixity :: C1 'BeforeTerm Assoc -> C1 'BeforeTerm Int -> C2 'BeforeTerm 'AfterTerm SymbolIdentifier -> C1 'BeforeTerm LowercaseIdentifier - -> AST typeRef ctorRef varRef getType 'TopLevelDeclarationNK + -> AST p getType 'TopLevelDeclarationNK -- -- Expressions -- - Unit :: - Comments - -> AST typeRef ctorRef varRef getType 'ExpressionNK - Literal :: - LiteralValue - -> AST typeRef ctorRef varRef getType 'ExpressionNK - VarExpr :: - varRef - -> AST typeRef ctorRef varRef getType 'ExpressionNK + Unit :: Comments -> AST p getType 'ExpressionNK + Literal :: LiteralValue -> AST p getType 'ExpressionNK + VarExpr :: getType 'VarRefNK -> AST p getType 'ExpressionNK App :: getType 'ExpressionNK - -> [C1 'BeforeTerm (getType 'ExpressionNK)] + -> List (C1 'BeforeTerm (getType 'ExpressionNK)) -> FunctionApplicationMultiline - -> AST typeRef ctorRef varRef getType 'ExpressionNK + -> AST p getType 'ExpressionNK Unary :: UnaryOperator -> getType 'ExpressionNK - -> AST typeRef ctorRef varRef getType 'ExpressionNK + -> AST p getType 'ExpressionNK Binops :: getType 'ExpressionNK - -> List (BinopsClause varRef (getType 'ExpressionNK)) -- Non-empty + -> List (BinopsClause (getType 'VarRefNK) (getType 'ExpressionNK)) -- Non-empty -> Bool - -> AST typeRef ctorRef varRef getType 'ExpressionNK + -> AST p getType 'ExpressionNK Parens :: C2 'BeforeTerm 'AfterTerm (getType 'ExpressionNK) - -> AST typeRef ctorRef varRef getType 'ExpressionNK + -> AST p getType 'ExpressionNK ExplicitList :: { terms :: Sequence (getType 'ExpressionNK) , trailingComments_el :: Comments , forceMultiline_el :: ForceMultiline } - -> AST typeRef ctorRef varRef getType 'ExpressionNK + -> AST p getType 'ExpressionNK Range :: C2 'BeforeTerm 'AfterTerm (getType 'ExpressionNK) -> C2 'BeforeTerm 'AfterTerm (getType 'ExpressionNK) - -> Bool - -> AST typeRef ctorRef varRef getType 'ExpressionNK + -> AST p getType 'ExpressionNK Tuple :: [C2 'BeforeTerm 'AfterTerm (getType 'ExpressionNK)] -> Bool - -> AST typeRef ctorRef varRef getType 'ExpressionNK + -> AST p getType 'ExpressionNK TupleFunction :: Int -- will be 2 or greater, indicating the number of elements in the tuple - -> AST typeRef ctorRef varRef getType 'ExpressionNK + -> AST p getType 'ExpressionNK Record :: { base_r :: Maybe (C2 'BeforeTerm 'AfterTerm LowercaseIdentifier) @@ -387,54 +502,54 @@ data AST typeRef ctorRef varRef (getType :: NodeKind -> Type) (kind :: NodeKind) , trailingComments_r :: Comments , forceMultiline_r :: ForceMultiline } - -> AST typeRef ctorRef varRef getType 'ExpressionNK + -> AST p getType 'ExpressionNK Access :: getType 'ExpressionNK -> LowercaseIdentifier - -> AST typeRef ctorRef varRef getType 'ExpressionNK + -> AST p getType 'ExpressionNK AccessFunction :: LowercaseIdentifier - -> AST typeRef ctorRef varRef getType 'ExpressionNK + -> AST p getType 'ExpressionNK Lambda :: [C1 'BeforeTerm (getType 'PatternNK)] -> Comments -> getType 'ExpressionNK -> Bool - -> AST typeRef ctorRef varRef getType 'ExpressionNK + -> AST p getType 'ExpressionNK If :: IfClause (getType 'ExpressionNK) -> [C1 'BeforeTerm (IfClause (getType 'ExpressionNK))] -> C1 'BeforeTerm (getType 'ExpressionNK) - -> AST typeRef ctorRef varRef getType 'ExpressionNK + -> AST p getType 'ExpressionNK Let :: [getType 'LetDeclarationNK] -> Comments -> getType 'ExpressionNK - -> AST typeRef ctorRef varRef getType 'ExpressionNK + -> AST p getType 'ExpressionNK LetCommonDeclaration :: getType 'CommonDeclarationNK - -> AST typeRef ctorRef varRef getType 'LetDeclarationNK + -> AST p getType 'LetDeclarationNK LetComment :: Comment - -> AST typeRef ctorRef varRef getType 'LetDeclarationNK + -> AST p getType 'LetDeclarationNK Case :: (C2 'BeforeTerm 'AfterTerm (getType 'ExpressionNK), Bool) -> [getType 'CaseBranchNK] - -> AST typeRef ctorRef varRef getType 'ExpressionNK + -> AST p getType 'ExpressionNK CaseBranch :: { beforePattern :: Comments , beforeArrow :: Comments , afterArrow :: Comments , pattern :: getType 'PatternNK - , body :: getType 'ExpressionNK + , caseBranchBody :: getType 'ExpressionNK } - -> AST typeRef ctorRef varRef getType 'CaseBranchNK + -> AST p getType 'CaseBranchNK -- for type checking and code gen only GLShader :: String - -> AST typeRef ctorRef varRef getType 'ExpressionNK + -> AST p getType 'ExpressionNK -- @@ -442,50 +557,50 @@ data AST typeRef ctorRef varRef (getType :: NodeKind -> Type) (kind :: NodeKind) -- Anything :: - AST typeRef ctorRef varRef getType 'PatternNK + AST p getType 'PatternNK UnitPattern :: Comments - -> AST typeRef ctorRef varRef getType 'PatternNK + -> AST p getType 'PatternNK LiteralPattern :: LiteralValue - -> AST typeRef ctorRef varRef getType 'PatternNK + -> AST p getType 'PatternNK VarPattern :: LowercaseIdentifier - -> AST typeRef ctorRef varRef getType 'PatternNK + -> AST p getType 'PatternNK OpPattern :: SymbolIdentifier - -> AST typeRef ctorRef varRef getType 'PatternNK + -> AST p getType 'PatternNK DataPattern :: - ctorRef + getType 'CtorRefNK -> [C1 'BeforeTerm (getType 'PatternNK)] - -> AST typeRef ctorRef varRef getType 'PatternNK + -> AST p getType 'PatternNK PatternParens :: C2 'BeforeTerm 'AfterTerm (getType 'PatternNK) - -> AST typeRef ctorRef varRef getType 'PatternNK + -> AST p getType 'PatternNK TuplePattern :: [C2 'BeforeTerm 'AfterTerm (getType 'PatternNK)] - -> AST typeRef ctorRef varRef getType 'PatternNK + -> AST p getType 'PatternNK EmptyListPattern :: Comments - -> AST typeRef ctorRef varRef getType 'PatternNK + -> AST p getType 'PatternNK ListPattern :: [C2 'BeforeTerm 'AfterTerm (getType 'PatternNK)] - -> AST typeRef ctorRef varRef getType 'PatternNK + -> AST p getType 'PatternNK ConsPattern :: { first_cp :: C0Eol (getType 'PatternNK) , rest_cp :: Sequence (getType 'PatternNK) } - -> AST typeRef ctorRef varRef getType 'PatternNK + -> AST p getType 'PatternNK EmptyRecordPattern :: Comments - -> AST typeRef ctorRef varRef getType 'PatternNK + -> AST p getType 'PatternNK RecordPattern :: [C2 'BeforeTerm 'AfterTerm LowercaseIdentifier] - -> AST typeRef ctorRef varRef getType 'PatternNK + -> AST p getType 'PatternNK Alias :: C1 'AfterTerm (getType 'PatternNK) -> C1 'BeforeTerm LowercaseIdentifier - -> AST typeRef ctorRef varRef getType 'PatternNK + -> AST p getType 'PatternNK -- @@ -494,69 +609,100 @@ data AST typeRef ctorRef varRef (getType :: NodeKind -> Type) (kind :: NodeKind) UnitType :: Comments - -> AST typeRef ctorRef varRef getType 'TypeNK + -> AST p getType 'TypeNK TypeVariable :: LowercaseIdentifier - -> AST typeRef ctorRef varRef getType 'TypeNK + -> AST p getType 'TypeNK TypeConstruction :: - TypeConstructor typeRef + TypeConstructor (getType 'TypeRefNK) -> [C1 'BeforeTerm (getType 'TypeNK)] -> ForceMultiline - -> AST typeRef ctorRef varRef getType 'TypeNK + -> AST p getType 'TypeNK TypeParens :: C2 'BeforeTerm 'AfterTerm (getType 'TypeNK) - -> AST typeRef ctorRef varRef getType 'TypeNK + -> AST p getType 'TypeNK TupleType :: - [C2Eol 'BeforeTerm 'AfterTerm (getType 'TypeNK)] + NonEmpty (C2Eol 'BeforeTerm 'AfterTerm (getType 'TypeNK)) -> ForceMultiline - -> AST typeRef ctorRef varRef getType 'TypeNK + -> AST p getType 'TypeNK RecordType :: { base_rt :: Maybe (C2 'BeforeTerm 'AfterTerm LowercaseIdentifier) , fields_rt :: Sequence (Pair LowercaseIdentifier (getType 'TypeNK)) , trailingComments_rt :: Comments , forceMultiline_rt :: ForceMultiline } - -> AST typeRef ctorRef varRef getType 'TypeNK + -> AST p getType 'TypeNK FunctionType :: { first_ft :: C0Eol (getType 'TypeNK) , rest_ft :: Sequence (getType 'TypeNK) , forceMultiline_ft :: ForceMultiline } - -> AST typeRef ctorRef varRef getType 'TypeNK + -> AST p getType 'TypeNK deriving instance - ( Eq typeRef, Eq ctorRef, Eq varRef + ( Eq (getType 'ModuleNK) + , Eq (getType 'ImportMethodNK) + , Eq (getType 'ModuleListingNK) + , Eq (getType 'ModuleHeaderNK) + , Eq (getType 'ModuleBodyNK) , Eq (getType 'CommonDeclarationNK) , Eq (getType 'TopLevelDeclarationNK) + , Eq (getType 'TypeRefNK) + , Eq (getType 'CtorRefNK) + , Eq (getType 'VarRefNK) , Eq (getType 'ExpressionNK) , Eq (getType 'LetDeclarationNK) , Eq (getType 'CaseBranchNK) , Eq (getType 'PatternNK) , Eq (getType 'TypeNK) + , Eq (TypeRef p) -- TODO: is there a way to not need UndecidableInstances for this? + , Eq (CtorRef p) + , Eq (VarRef p) ) => - Eq (AST typeRef ctorRef varRef getType kind) + Eq (AST p getType kind) deriving instance - ( Show typeRef, Show ctorRef, Show varRef + ( Show (getType 'ModuleNK) + , Show (getType 'ImportMethodNK) + , Show (getType 'ModuleListingNK) + , Show (getType 'ModuleHeaderNK) + , Show (getType 'ModuleBodyNK) , Show (getType 'CommonDeclarationNK) , Show (getType 'TopLevelDeclarationNK) + , Show (getType 'TypeRefNK) + , Show (getType 'CtorRefNK) + , Show (getType 'VarRefNK) , Show (getType 'ExpressionNK) , Show (getType 'LetDeclarationNK) , Show (getType 'CaseBranchNK) , Show (getType 'PatternNK) , Show (getType 'TypeNK) + , Show (TypeRef p) + , Show (CtorRef p) + , Show (VarRef p) ) => - Show (AST typeRef ctorRef varRef getType kind) + Show (AST p getType kind) mapAll :: - (typeRef1 -> typeRef2) -> (ctorRef1 -> ctorRef2) -> (varRef1 -> varRef2) + (TypeRef p1 -> TypeRef p2) + -> (CtorRef p1 -> CtorRef p2) + -> (VarRef p1 -> VarRef p2) -> (forall kind. getType1 kind -> getType2 kind) -> (forall kind. - AST typeRef1 ctorRef1 varRef1 getType1 kind - -> AST typeRef2 ctorRef2 varRef2 getType2 kind + AST p1 getType1 kind + -> AST p2 getType2 kind ) mapAll ftyp fctor fvar fast = \case - TopLevel tls -> TopLevel (fmap (fmap fast) tls) + TypeRef_ r -> TypeRef_ (ftyp r) + CtorRef_ r -> CtorRef_ (fctor r) + VarRef_ r -> VarRef_ (fvar r) + + -- Module + Module c h d i b -> Module c (fmap fast h) d (fmap (fmap $ fmap fast) i) (fast b) + ImportMethod as exp -> ImportMethod as (fmap fast exp) + ModuleListing lst -> ModuleListing lst + ModuleHeader st n s e -> ModuleHeader st n s (fmap (fmap fast) e) + ModuleBody ds -> ModuleBody (fmap (fmap fast) ds) -- Declaration Definition name args c e -> Definition (fast name) (fmap (fmap fast) args) c (fast e) @@ -566,19 +712,19 @@ mapAll ftyp fctor fvar fast = \case TypeAlias c nameWithArgs t -> TypeAlias c nameWithArgs (fmap fast t) PortAnnotation name c t -> PortAnnotation name c (fast t) PortDefinition_until_0_16 name c e -> PortDefinition_until_0_16 name c (fast e) - Fixity_until_0_18 a c n c' name -> Fixity_until_0_18 a c n c' (fvar name) + Fixity_until_0_18 a c n c' name -> Fixity_until_0_18 a c n c' (fast name) Fixity a n op name -> Fixity a n op name -- Expressions Unit c -> Unit c Literal l -> Literal l - VarExpr var -> VarExpr (fvar var) + VarExpr var -> VarExpr (fast var) App first rest ml -> App (fast first) (fmap (fmap fast) rest) ml Unary op e -> Unary op (fast e) - Binops first ops ml -> Binops (fast first) (fmap (bimap fvar fast) ops) ml + Binops first ops ml -> Binops (fast first) (fmap (bimap fast fast) ops) ml Parens e -> Parens (fmap fast e) ExplicitList terms c ml -> ExplicitList (fmap fast terms) c ml - Range left right ml -> Range (fmap fast left) (fmap fast right) ml + Range left right -> Range (fmap fast left) (fmap fast right) Tuple terms ml -> Tuple (fmap (fmap fast) terms) ml TupleFunction n -> TupleFunction n Record base fields c ml -> Record base (fmap (fmap fast) fields) c ml @@ -599,7 +745,7 @@ mapAll ftyp fctor fvar fast = \case LiteralPattern l -> LiteralPattern l VarPattern l -> VarPattern l OpPattern s -> OpPattern s - DataPattern ctor pats -> DataPattern (fctor ctor) (fmap (fmap fast) pats) + DataPattern ctor pats -> DataPattern (fast ctor) (fmap (fmap fast) pats) PatternParens pat -> PatternParens (fmap fast pat) TuplePattern pats -> TuplePattern (fmap (fmap fast) pats) EmptyListPattern c -> EmptyListPattern c @@ -612,17 +758,78 @@ mapAll ftyp fctor fvar fast = \case -- Types UnitType c -> UnitType c TypeVariable name -> TypeVariable name - TypeConstruction name args forceMultiline -> TypeConstruction (fmap ftyp name) (fmap (fmap fast) args) forceMultiline + TypeConstruction name args forceMultiline -> TypeConstruction (fmap fast name) (fmap (fmap fast) args) forceMultiline TypeParens typ -> TypeParens (fmap fast typ) TupleType typs forceMultiline -> TupleType (fmap (fmap fast) typs) forceMultiline RecordType base fields c ml -> RecordType base (fmap (fmap fast) fields) c ml FunctionType first rest ml -> FunctionType (fmap fast first) (fmap fast rest) ml - -instance I.IFunctor (AST typeRef ctorRef varRef) where +instance I.HFunctor (AST p) where -- TODO: it's probably worth making an optimized version of this - imap = mapAll id id id - + hmap = mapAll id id id + +instance I.HFoldable (AST p) where + hFoldMap f = \case + TypeRef_ _ -> mempty + CtorRef_ _ -> mempty + VarRef_ _ -> mempty + Module _ header _ imports body -> foldMap f header <> foldMap (foldMap $ foldMap f) imports <> f body + ImportMethod _ exp -> foldMap f exp + ModuleListing _ -> mempty + ModuleHeader _ _ _ exports -> foldMap (foldMap f) exports + ModuleBody defs -> foldMap (foldMap f) defs + Definition pat args _ expr -> f pat <> foldMap (f . extract) args <> f expr + TypeAnnotation _ typ -> f (extract typ) + CommonDeclaration def -> f def + Datatype _ tags -> foldMap (foldMap f) tags + TypeAlias _ _ typ -> f (extract typ) + PortAnnotation _ _ typ -> f typ + PortDefinition_until_0_16 _ _ typ -> f typ + Fixity_until_0_18 _ _ _ _ ref -> f ref + Fixity {} -> mempty + Unit _ -> mempty + Literal _ -> mempty + VarExpr var -> f var + App first rest _ -> f first <> foldMap (f . extract) rest + Unary _ expr -> f expr + Binops first rest _ -> f first <> foldMap (bifoldMap f f) rest + Parens term -> f (extract term) + ExplicitList terms _ _ -> foldMap f terms + Range a b -> f (extract a) <> f (extract b) + Tuple terms _ -> foldMap (f . extract) terms + TupleFunction _ -> mempty + Record _ fields _ _ -> foldMap (foldMap f) fields + Access term _ -> f term + AccessFunction _ -> mempty + Lambda pats _ expr _ -> foldMap (f . extract) pats <> f expr + If first rest last -> foldMap f first <> foldMap (foldMap f . extract) rest <> f (extract last) + Let defs _ expr -> foldMap f defs <> f expr + LetCommonDeclaration def -> f def + LetComment _ -> mempty + Case pred branches -> f (extract $ fst pred) <> foldMap f branches + CaseBranch _ _ _ pat expr -> f pat <> f expr + GLShader _ -> mempty + Anything -> mempty + UnitPattern _ -> mempty + LiteralPattern _ -> mempty + VarPattern _ -> mempty + OpPattern _ -> mempty + DataPattern ctor args -> f ctor <> foldMap (f . extract) args + PatternParens pat -> f (extract pat) + TuplePattern pats -> foldMap (f . extract) pats + EmptyListPattern _ -> mempty + ListPattern pats -> foldMap (f . extract) pats + ConsPattern first rest -> f (extract first) <> foldMap f rest + EmptyRecordPattern _ -> mempty + RecordPattern _ -> mempty + Alias pat _ -> f (extract pat) + UnitType _ -> mempty + TypeVariable _ -> mempty + TypeConstruction tc args _ -> foldMap f tc <> foldMap (f . extract) args + TypeParens t -> f $ extract t + TupleType ne _ -> foldMap (f . extract) ne + RecordType _ fs _ _ -> foldMap (foldMap f) fs + FunctionType ft se _ -> f (extract ft) <> foldMap f se -- @@ -633,22 +840,23 @@ instance I.IFunctor (AST typeRef ctorRef varRef) where topDownReferencesWithContext :: forall context ns - typeRef2 ctorRef2 varRef2 + p2 ann kind. Functor ann => Coapplicative ann => + ASTParameters p2 => (LocalName -> context -> context) -- TODO: since the caller typically passes a function that builds a Map or Set, this could be optimized by taking `List (LocalName)` instead of one at a time - -> (context -> (ns, UppercaseIdentifier) -> typeRef2) - -> (context -> (ns, UppercaseIdentifier) -> ctorRef2) - -> (context -> Ref ns -> varRef2) + -> (context -> (ns, UppercaseIdentifier) -> TypeRef p2) + -> (context -> (ns, UppercaseIdentifier) -> CtorRef p2) + -> (context -> Ref ns -> VarRef p2) -> context - -> I.Fix ann (AST (ns, UppercaseIdentifier) (ns, UppercaseIdentifier) (Ref ns)) kind - -> I.Fix ann (AST typeRef2 ctorRef2 varRef2) kind + -> I.Fix2 ann (AST (VariableNamespace ns)) kind + -> I.Fix2 ann (AST p2) kind topDownReferencesWithContext defineLocal fType fCtor fVar initialContext initialAst = let namesFromPattern' :: - forall a b c kind'. -- We actually only care about PatternNK' here - AST a b c (Const [LocalName]) kind' + forall p kind'. -- We actually only care about PatternNK' here + AST p (Const [LocalName]) kind' -> Const [LocalName] kind' namesFromPattern' = \case Anything -> mempty @@ -668,17 +876,17 @@ topDownReferencesWithContext defineLocal fType fCtor fVar initialContext initial namesFromPattern :: Coapplicative ann' => - I.Fix ann' (AST a b c) kind' + I.Fix2 ann' (AST p) kind' -> [LocalName] namesFromPattern = - getConst . I.cata (namesFromPattern' . extract) + getConst . I.fold2 (namesFromPattern' . extract) namesFrom :: Coapplicative ann' => - I.Fix ann' (AST a b c) kind' + I.Fix2 ann' (AST p) kind' -> [LocalName] namesFrom decl = - case extract $ I.unFix decl of + case extract $ I.unFix2 decl of Definition p _ _ _ -> namesFromPattern p TypeAnnotation _ _ -> mempty @@ -697,17 +905,20 @@ topDownReferencesWithContext defineLocal fType fCtor fVar initialContext initial newDefinitionsAtNode :: forall kind'. - AST (ns, UppercaseIdentifier) (ns, UppercaseIdentifier) (Ref ns) - (I.Fix ann (AST (ns, UppercaseIdentifier) (ns, UppercaseIdentifier) (Ref ns))) + AST (VariableNamespace ns) + (I.Fix2 ann (AST (VariableNamespace ns))) kind' -> [LocalName] newDefinitionsAtNode node = case node of - TopLevel decls -> + Module _ _ _ _ body -> + newDefinitionsAtNode (extract $ I.unFix2 body) + + ModuleBody decls -> foldMap (foldMap namesFrom) decls CommonDeclaration d -> - newDefinitionsAtNode (extract $ I.unFix d) + newDefinitionsAtNode (extract $ I.unFix2 d) Definition first rest _ _ -> foldMap namesFromPattern (first : fmap extract rest) @@ -719,7 +930,7 @@ topDownReferencesWithContext defineLocal fType fCtor fVar initialContext initial foldMap namesFrom decls LetCommonDeclaration d -> - newDefinitionsAtNode (extract $ I.unFix d) + newDefinitionsAtNode (extract $ I.unFix2 d) CaseBranch _ _ _ p _ -> namesFromPattern p @@ -730,13 +941,13 @@ topDownReferencesWithContext defineLocal fType fCtor fVar initialContext initial step :: forall kind'. context - -> AST (ns, UppercaseIdentifier) (ns, UppercaseIdentifier) (Ref ns) - (I.Fix ann (AST (ns, UppercaseIdentifier) (ns, UppercaseIdentifier) (Ref ns))) + -> AST (VariableNamespace ns) + (I.Fix2 ann (AST (VariableNamespace ns))) kind' - -> AST typeRef2 ctorRef2 varRef2 + -> AST p2 (Compose ((,) context) - (I.Fix ann (AST (ns, UppercaseIdentifier) (ns, UppercaseIdentifier) (Ref ns))) + (I.Fix2 ann (AST (VariableNamespace ns))) ) kind' step context node = @@ -744,8 +955,8 @@ topDownReferencesWithContext defineLocal fType fCtor fVar initialContext initial context' = foldl (flip defineLocal) context (newDefinitionsAtNode node) in mapAll (fType context') (fCtor context') (fVar context') id - $ I.imap (Compose . (,) context') node + $ I.hmap (Compose . (,) context') node in - I.ana - (\(Compose (context, ast)) -> step context <$> I.unFix ast) + I.unfold2 + (\(Compose (context, ast)) -> step context <$> I.unFix2 ast) (Compose (initialContext, initialAst)) diff --git a/elm-format-lib/src/Box.hs b/elm-format-lib/src/Box.hs index 3f0645f66..c5a026ce7 100644 --- a/elm-format-lib/src/Box.hs +++ b/elm-format-lib/src/Box.hs @@ -1,15 +1,19 @@ -{-# OPTIONS_GHC -Wall #-} module Box ( Line, identifier, keyword, punc, literal, row, space , Box(SingleLine, MustBreak), blankLine, line, mustBreak, stack', stack1, andThen - , isLine, allSingles, lineLength + , isLine, allSingles , indent, prefix, addSuffix , render - ) where + ,allSingles2,allSingles3,lineLength,isSingle,isMustBreak,comment,stack,joinMustBreak,prefixOrIndent) where -import Elm.Utils ((|>)) +import Data.Fix +import Elm.Utils (List) import qualified Data.Text as T +import Indent (Indent) +import qualified Indent +import Data.Semigroup (sconcat) +import Data.List.NonEmpty (NonEmpty((:|))) {- @@ -20,42 +24,58 @@ Space is self-explanatory, Text brings any string into the data structure, Row joins more of these elements onto one line. -} -data Line +data LineF a = Text T.Text - | Row [Line] + | Row a a | Space - | Tab +type Line = Fix LineF -identifier :: String -> Line +instance Semigroup Line where + a <> b = Fix $ Row a b + + +identifier :: T.Text -> Line identifier = - Text . T.pack + Fix . Text -keyword :: String -> Line +keyword :: T.Text -> Line keyword = - Text . T.pack + Fix . Text -punc :: String -> Line +punc :: T.Text -> Line punc = - Text . T.pack + Fix . Text -literal :: String -> Line +literal :: T.Text -> Line literal = - Text . T.pack + Fix . Text + + +comment :: T.Text -> Line +comment = + Fix . Text --- join more Line elements into one -row :: [Line] -> Line -row = - Row +{-# DEPRECATED row "use `(<>)` instead" #-} +{-| join more Line elements into one +-} +row :: List Line -> Line +row [] = error $ "" +row (first:rest) = sconcat (first:|rest) space :: Line space = - Space + Fix Space + + +data Indented a = + Indented Indent a + deriving (Functor) {- @@ -74,9 +94,9 @@ Sometimes (see `prefix`) the first line of Stack gets different treatment than the other lines. -} data Box - = SingleLine Line - | Stack Line Line [Line] - | MustBreak Line + = SingleLine (Indented Line) + | Stack (Indented Line) (Indented Line) [Indented Line] + | MustBreak (Indented Line) blankLine :: Box @@ -85,13 +105,22 @@ blankLine = line :: Line -> Box -line l = - SingleLine l +line = + SingleLine . mkIndentedLine mustBreak :: Line -> Box -mustBreak l = - MustBreak l +mustBreak = + MustBreak . mkIndentedLine + + +mkIndentedLine :: Line -> Indented Line +mkIndentedLine (Fix Space) = Indented (Indent.spaces 1) (literal "") +mkIndentedLine (Fix (Row (Fix Space) next)) = + let (Indented i rest') = mkIndentedLine next + in + Indented (Indent.spaces 1 <> i) rest' +mkIndentedLine other = Indented mempty other stack' :: Box -> Box -> Box @@ -111,6 +140,11 @@ andThen rest first = foldl stack' first rest +stack :: Box -> [Box] -> Box +stack first rest = stack1 (first:rest) + + +{-# DEPRECATED stack1 "Prefer `stack` or `stack'`" #-} stack1 :: [Box] -> Box stack1 children = case children of @@ -122,12 +156,42 @@ stack1 children = foldr1 stack' boxes -mapLines :: (Line -> Line) -> Box -> Box +joinMustBreak :: Box -> Box -> Box +joinMustBreak inner eol = + case (inner, eol) of + (SingleLine (Indented i1 inner'), SingleLine (Indented _ eol')) -> + SingleLine $ Indented i1 $ + inner' <> space <> eol' + + (SingleLine (Indented i1 inner'), MustBreak (Indented _ eol')) -> + MustBreak $ Indented i1 $ + inner' <> space <> eol' + + _ -> + stack' inner eol + + +prefixOrIndent :: Box -> Box -> Box +prefixOrIndent a b = + case ( a, b ) of + (SingleLine (Indented i1 a'), SingleLine (Indented _ b')) -> + SingleLine $ Indented i1 $ + a' <> space <> b' + + (SingleLine (Indented i1 a'), MustBreak (Indented _ b')) -> + MustBreak $ Indented i1 $ + a' <> space <> b' + + _ -> + stack' a (indent b) + + +mapLines :: (Indented Line -> Indented Line) -> Box -> Box mapLines fn = mapFirstLine fn fn -mapFirstLine :: (Line -> Line) -> (Line -> Line) -> Box -> Box +mapFirstLine :: (Indented Line -> Indented Line) -> (Indented Line -> Indented Line) -> Box -> Box mapFirstLine firstFn restFn b = case b of SingleLine l1 -> @@ -138,21 +202,51 @@ mapFirstLine firstFn restFn b = MustBreak (firstFn l1) +mapLastLine :: (Indented Line -> Indented Line) -> Box -> Box +mapLastLine lastFn = \case + SingleLine l1 -> + SingleLine (lastFn l1) + Stack l1 l2 [] -> + Stack l1 (lastFn l2) [] + Stack l1 l2 ls -> + Stack l1 l2 (init ls ++ [lastFn $ last ls]) + MustBreak l1 -> + MustBreak (lastFn l1) + + indent :: Box -> Box indent = - mapLines (\l -> row [Tab, l]) + mapLines (\(Indented i l) -> Indented (Indent.tab <> i) l) isLine :: Box -> Either Box Line isLine b = case b of - SingleLine l -> + SingleLine (Indented _ l) -> Right l _ -> Left b -destructure :: Box -> (Line, [Line]) +isSingle :: Box -> Maybe Line +isSingle b = + case b of + SingleLine (Indented _ l) -> + Just l + _ -> + Nothing + + +isMustBreak :: Box -> Maybe Line +isMustBreak b = + case b of + MustBreak (Indented _ l) -> + Just l + _ -> + Nothing + + +destructure :: Box -> (Indented Line, [Indented Line]) destructure b = case b of SingleLine l1 -> @@ -163,19 +257,35 @@ destructure b = (l1, []) -allSingles :: [Box] -> Either [Box] [Line] +allSingles :: Traversable t => t Box -> Either (t Box) (t Line) allSingles boxes = - case sequence $ map isLine boxes of + case mapM isLine boxes of Right lines' -> Right lines' _ -> Left boxes +allSingles2 :: Box -> Box -> Either (Box, Box) (Line, Line) +allSingles2 b1 b2 = + case allSingles [b1, b2] of + Right [l1, l2] -> Right (l1, l2) + _ -> Left (b1, b2) + + +allSingles3 :: Box -> Box -> Box -> Either (Box, Box, Box) (Line, Line, Line) +allSingles3 b1 b2 b3 = + case allSingles [b1, b2, b3] of + Right [l1, l2, l3] -> Right (l1, l2, l3) + _ -> Left (b1, b2, b3) + + {- Add the prefix to the first line, pad the other lines with spaces of the same length +NOTE: An exceptional case that we haven't really designed for is if the first line of the input Box is indented. + EXAMPLE: abcde xyz @@ -186,127 +296,44 @@ myPrefix abcde prefix :: Line -> Box -> Box prefix pref = let - prefixLength = lineLength 0 pref - paddingSpaces = replicate prefixLength space - padLineWithSpaces l = row [ row paddingSpaces, l ] - addPrefixToLine l = row [ pref, l ] + prefixLength = fromIntegral $ T.length $ renderLine pref + padLineWithSpaces (Indented i l) = Indented (Indent.spaces prefixLength <> i) l + addPrefixToLine l = pref <> l in - mapFirstLine addPrefixToLine padLineWithSpaces + mapFirstLine (fmap addPrefixToLine) padLineWithSpaces addSuffix :: Line -> Box -> Box -addSuffix suffix b = - case destructure b of - (l,[]) -> - line $ row [ l, suffix ] - (l1,ls) -> - line l1 - |> andThen (map line $ init ls) - |> andThen [ line $ row [ last ls, suffix ] ] - - -renderLine :: Int -> Line -> T.Text -renderLine startColumn line' = - case line' of +addSuffix suffix = + mapLastLine $ fmap (<> suffix) + + +renderIndentedLine :: Indented T.Text -> T.Text +renderIndentedLine (Indented i line') = + T.replicate (Indent.width i) " " <> line' + + +renderLine :: Line -> T.Text +renderLine line' = + case unFix line' of Text text -> text Space -> T.singleton ' ' - Tab -> - T.pack $ replicate (tabLength startColumn) ' ' - Row lines' -> - renderRow startColumn lines' + Row left right -> + renderLine left <> renderLine right render :: Box -> T.Text render box' = case box' of SingleLine line' -> - T.snoc (T.stripEnd $ renderLine 0 line') '\n' + T.snoc (T.stripEnd $ renderIndentedLine $ renderLine <$> line') '\n' Stack l1 l2 rest -> - T.unlines $ map (T.stripEnd . renderLine 0) (l1 : l2 : rest) + T.unlines $ map (T.stripEnd . renderIndentedLine . fmap renderLine) (l1 : l2 : rest) MustBreak line' -> - T.snoc (T.stripEnd $ renderLine 0 line') '\n' - - -lineLength :: Int -> Line -> Int -lineLength startColumn line' = - startColumn + - case line' of - Text string -> T.length string - Space -> 1 - Tab -> tabLength startColumn - Row lines' -> rowLength startColumn lines' - - -initRow :: Int -> (T.Text, Int) -initRow startColumn = - (T.empty, startColumn) + T.snoc (T.stripEnd $ renderIndentedLine $ renderLine <$> line') '\n' -spacesInTab :: Int -spacesInTab = - 4 - - -spacesToNextTab :: Int -> Int -spacesToNextTab startColumn = - startColumn `mod` spacesInTab - -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 (T.Text, 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 -> [Line] -> (T.Text, Int) -renderRow' startColumn lines' = - (result, resultLength) - where - (result, endColumn) = foldl addLine (initRow startColumn) lines' - resultLength = endColumn - startColumn - -{- -A step function for renderRow'. - -addLine (" ",1) Tab == (" ",4) --} -addLine :: (T.Text, Int) -> Line -> (T.Text, Int) -addLine (string, startColumn') line' = - (newString, newStartColumn) - where - newString = T.append string $ renderLine startColumn' line' - newStartColumn = lineLength startColumn' line' - --- Extract the final string from renderRow' -renderRow :: Int -> [Line] -> T.Text -renderRow startColumn lines' = - fst $ renderRow' startColumn lines' - --- Extract the final length from renderRow' -rowLength :: Int -> [Line] -> Int -rowLength startColumn lines' = - snd $ renderRow' startColumn lines' +lineLength :: Line -> Int +lineLength = T.length . renderLine diff --git a/elm-format-lib/src/ElmFormat/AST/PatternMatching.hs b/elm-format-lib/src/ElmFormat/AST/PatternMatching.hs index 9dbd56ba5..7f66a3c49 100644 --- a/elm-format-lib/src/ElmFormat/AST/PatternMatching.hs +++ b/elm-format-lib/src/ElmFormat/AST/PatternMatching.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} module ElmFormat.AST.PatternMatching where @@ -17,18 +16,18 @@ TODO: retain all comments in the output TODO: make complete function so it doesn't crash on invalid source files -} matchType :: - List (C1 'BeforeTerm (ASTNS Located ns 'PatternNK)) - -> ASTNS Located ns 'TypeNK - -> ( List (C1 'BeforeTerm (ASTNS Located ns 'PatternNK), ASTNS Located ns 'TypeNK) - , ASTNS Located ns 'TypeNK + List (C1 'BeforeTerm (I.Fix2 Located (ASTNS ns) 'PatternNK)) + -> I.Fix2 Located (ASTNS ns) 'TypeNK + -> ( List (C1 'BeforeTerm (I.Fix2 Located (ASTNS ns) 'PatternNK), I.Fix2 Located (ASTNS ns) 'TypeNK) + , I.Fix2 Located (ASTNS ns) 'TypeNK ) matchType [] typ = ( [], typ ) -matchType (pat : restPat) (I.Fix (At region (FunctionType (C eol typ) restTyp multiline))) = +matchType (pat : restPat) (I.Fix2 (At region (FunctionType (C eol typ) restTyp multiline))) = let nextTyp = case toCommentedList restTyp of [ (C _ single) ] -> single - ( (C (_, _, eol2) first) : rest ) -> I.Fix $ At region $ FunctionType (C eol2 first) (Sequence rest) multiline + ( (C (_, _, eol2) first) : rest ) -> I.Fix2 $ At region $ FunctionType (C eol2 first) (Sequence rest) multiline ( pats, retType ) = matchType restPat nextTyp diff --git a/elm-format-lib/src/ElmFormat/AST/PublicAST/Core.hs b/elm-format-lib/src/ElmFormat/AST/PublicAST/Core.hs index 53a946784..02958ea27 100644 --- a/elm-format-lib/src/ElmFormat/AST/PublicAST/Core.hs +++ b/elm-format-lib/src/ElmFormat/AST/PublicAST/Core.hs @@ -1,7 +1,4 @@ {-# LANGUAGE TupleSections #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_GHC -Wno-orphans #-} module ElmFormat.AST.PublicAST.Core @@ -35,8 +32,6 @@ import ElmFormat.AST.Shared import AST.V0_16 (NodeKind(..), Pair(..)) import AST.Structure (ASTNS, ASTNS1, mapNs) import qualified AST.V0_16 as AST -import qualified AST.Module as AST -import qualified AST.Listing as AST import Data.Indexed as I import Reporting.Annotation (Located, Region, Position) import qualified Reporting.Annotation as A @@ -72,17 +67,17 @@ class ToPublicAST (nk :: NodeKind) where type PublicAST nk fromRawAST' :: Config -> ASTNS1 Located [UppercaseIdentifier] nk -> PublicAST nk -fromRawAST :: ToPublicAST nk => Config -> ASTNS Located [UppercaseIdentifier] nk -> LocatedIfRequested (PublicAST nk) +fromRawAST :: ToPublicAST nk => Config -> I.Fix2 Located (ASTNS [UppercaseIdentifier]) nk -> LocatedIfRequested (PublicAST nk) fromRawAST config = - fmap (fromRawAST' config) . fromLocated config . I.unFix + fmap (fromRawAST' config) . fromLocated config . I.unFix2 class ToPublicAST nk => FromPublicAST (nk :: NodeKind) where - toRawAST' :: PublicAST nk -> ASTNS1 Identity [UppercaseIdentifier] nk + toRawAST' :: PublicAST nk -> I.Fix (ASTNS [UppercaseIdentifier]) nk -toRawAST :: FromPublicAST nk => LocatedIfRequested (PublicAST nk) -> ASTNS Identity [UppercaseIdentifier] nk +toRawAST :: FromPublicAST nk => LocatedIfRequested (PublicAST nk) -> I.Fix (ASTNS [UppercaseIdentifier]) nk toRawAST = - I.Fix . Identity . toRawAST' . extract + toRawAST' . extract -- diff --git a/elm-format-lib/src/ElmFormat/AST/PublicAST/Expression.hs b/elm-format-lib/src/ElmFormat/AST/PublicAST/Expression.hs index 9b2805559..bbadf886a 100644 --- a/elm-format-lib/src/ElmFormat/AST/PublicAST/Expression.hs +++ b/elm-format-lib/src/ElmFormat/AST/PublicAST/Expression.hs @@ -1,6 +1,4 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE DuplicateRecordFields #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -45,26 +43,26 @@ data LetDeclaration = LetDefinition Definition | Comment_ld Comment -mkLetDeclarations :: Config -> List (ASTNS Located [UppercaseIdentifier] 'LetDeclarationNK) -> List (MaybeF LocatedIfRequested LetDeclaration) +mkLetDeclarations :: Config -> List (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'LetDeclarationNK) -> List (MaybeF LocatedIfRequested LetDeclaration) mkLetDeclarations config decls = let toDefBuilder :: ASTNS1 Located [UppercaseIdentifier] 'LetDeclarationNK -> DefinitionBuilder LetDeclaration toDefBuilder = \case - AST.LetCommonDeclaration (I.Fix (At _ def)) -> + AST.LetCommonDeclaration (I.Fix2 (At _ def)) -> Right def AST.LetComment comment -> Left $ Comment_ld (mkComment comment) in - mkDefinitions config LetDefinition $ fmap (JustF . fmap toDefBuilder . fromLocated config . I.unFix) decls + mkDefinitions config LetDefinition $ fmap (JustF . fmap toDefBuilder . fromLocated config . I.unFix2) decls -fromLetDeclaration :: LetDeclaration -> List (ASTNS Identity [UppercaseIdentifier] 'LetDeclarationNK) +fromLetDeclaration :: LetDeclaration -> List (I.Fix (ASTNS [UppercaseIdentifier]) 'LetDeclarationNK) fromLetDeclaration = \case LetDefinition def -> - I.Fix . Identity . AST.LetCommonDeclaration <$> fromDefinition def + I.Fix . AST.LetCommonDeclaration <$> fromDefinition def Comment_ld comment -> - pure $ I.Fix $ Identity $ AST.LetComment (fromComment comment) + pure $ I.Fix $ AST.LetComment (fromComment comment) instance ToJSON LetDeclaration where @@ -109,11 +107,11 @@ instance ToPublicAST 'CaseBranchNK where (JustF $ fromRawAST config body) instance FromPublicAST 'CaseBranchNK where - toRawAST' = \case + toRawAST' = I.Fix . \case CaseBranch pattern body -> AST.CaseBranch [] [] [] (toRawAST pattern) - (maybeF (I.Fix . Identity . toRawAST') toRawAST body) + (maybeF toRawAST' toRawAST body) instance ToPairs CaseBranch where toPairs = \case @@ -188,7 +186,7 @@ instance ToPublicAST 'ExpressionNK where AST.Literal lit -> LiteralExpression lit - AST.VarExpr var -> + AST.VarExpr (I.Fix2 (At _ (AST.VarRef_ var))) -> VariableReferenceExpression $ mkReference var AST.App expr args multiline -> @@ -201,7 +199,7 @@ instance ToPublicAST 'ExpressionNK where case BinaryOperatorPrecedence.parseElm0_19 first - ((\(AST.BinopsClause c1 op c2 expr) -> (op, expr)) <$> rest) + ((\(AST.BinopsClause c1 (I.Fix2 (At _ (AST.VarRef_ op))) c2 expr) -> (op, expr)) <$> rest) of Right tree -> extract $ buildTree tree @@ -209,7 +207,7 @@ instance ToPublicAST 'ExpressionNK where Left message -> error ("invalid binary operator expression: " <> Text.unpack message) where - buildTree :: BinaryOperatorPrecedence.Tree (Ref [UppercaseIdentifier ]) (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) -> MaybeF LocatedIfRequested Expression + buildTree :: BinaryOperatorPrecedence.Tree (Ref [UppercaseIdentifier ]) (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK) -> MaybeF LocatedIfRequested Expression buildTree (BinaryOperatorPrecedence.Leaf e) = JustF $ fromRawAST config e buildTree (BinaryOperatorPrecedence.Branch op e1 e2) = @@ -225,7 +223,7 @@ instance ToPublicAST 'ExpressionNK where (FunctionApplicationDisplay ShowAsFunctionApplication) AST.Parens (C comments expr) -> - fromRawAST' config $ extract $ I.unFix expr + fromRawAST' config $ extract $ I.unFix2 expr AST.ExplicitList terms comments multiline -> ListLiteral @@ -292,14 +290,14 @@ instance ToPublicAST 'ExpressionNK where (fromRawAST config <$> branches) (CaseDisplay False) - AST.Range _ _ _ -> + AST.Range _ _ -> error "Range syntax is not supported in Elm 0.19" AST.GLShader shader -> GLShader shader instance FromPublicAST 'ExpressionNK where - toRawAST' = \case + toRawAST' = I.Fix . \case UnitLiteral -> AST.Unit [] @@ -307,14 +305,14 @@ instance FromPublicAST 'ExpressionNK where AST.Literal lit VariableReferenceExpression var -> - AST.VarExpr $ toRef var + AST.VarExpr $ I.Fix $ AST.VarRef_ $ toRef var FunctionApplication function args display -> case (extract function, args) of (UnaryOperator operator, [ single ]) -> AST.Unary operator - (maybeF (I.Fix . Identity . toRawAST') toRawAST single) + (maybeF toRawAST' toRawAST single) (UnaryOperator _, []) -> undefined @@ -324,8 +322,8 @@ instance FromPublicAST 'ExpressionNK where _ -> AST.App - (maybeF (I.Fix . Identity . toRawAST') toRawAST function) - (C [] . maybeF (I.Fix . Identity . toRawAST') toRawAST <$> args) + (maybeF toRawAST' toRawAST function) + (C [] . maybeF toRawAST' toRawAST <$> args) (AST.FAJoinFirst AST.JoinAll) UnaryOperator _ -> @@ -633,9 +631,9 @@ data Definition mkDefinition :: Config -> ASTNS1 Located [UppercaseIdentifier] 'PatternNK - -> List (AST.C1 'AST.BeforeTerm (ASTNS Located [UppercaseIdentifier] 'PatternNK)) - -> Maybe (AST.C2 'AST.BeforeSeparator 'AST.AfterSeparator (ASTNS Located [UppercaseIdentifier] 'TypeNK)) - -> ASTNS Located [UppercaseIdentifier] 'ExpressionNK + -> List (AST.C1 'AST.BeforeTerm (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'PatternNK)) + -> Maybe (AST.C2 'AST.BeforeSeparator 'AST.AfterSeparator (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TypeNK)) + -> I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK -> Definition mkDefinition config pat args annotation expr = case pat of @@ -661,32 +659,32 @@ mkDefinition config pat args annotation expr = , show expr ] -fromDefinition :: Definition -> List (ASTNS Identity [UppercaseIdentifier] 'CommonDeclarationNK) +fromDefinition :: Definition -> List (I.Fix (ASTNS [UppercaseIdentifier]) 'CommonDeclarationNK) fromDefinition = \case Definition name parameters Nothing expression -> - pure $ I.Fix $ Identity $ AST.Definition - (I.Fix $ Identity $ AST.VarPattern name) + pure $ I.Fix $ AST.Definition + (I.Fix $ AST.VarPattern name) (C [] . toRawAST . pattern_tp <$> parameters) [] (toRawAST expression) Definition name [] (Just typ) expression -> - [ I.Fix $ Identity $ AST.TypeAnnotation + [ I.Fix $ AST.TypeAnnotation (C [] $ VarRef () name) (C [] $ toRawAST typ) - , I.Fix $ Identity $ AST.Definition - (I.Fix $ Identity $ AST.VarPattern name) + , I.Fix $ AST.Definition + (I.Fix $ AST.VarPattern name) [] [] (toRawAST expression) ] Definition name parameters (Just typ) expression -> - [ I.Fix $ Identity $ AST.TypeAnnotation + [ I.Fix $ AST.TypeAnnotation (C [] $ VarRef () name) (C [] $ toRawAST $ LocatedIfRequested $ NothingF $ FunctionType typ (fromMaybe (LocatedIfRequested $ NothingF UnitType) . type_tp <$> parameters)) - , I.Fix $ Identity $ AST.Definition - (I.Fix $ Identity $ AST.VarPattern name) + , I.Fix $ AST.Definition + (I.Fix $ AST.VarPattern name) (C [] . toRawAST . pattern_tp <$> parameters) [] (toRawAST expression) @@ -703,21 +701,21 @@ mkDefinitions :: -> List (MaybeF LocatedIfRequested a) mkDefinitions config fromDef items = let - collectAnnotation :: DefinitionBuilder a -> Maybe (LowercaseIdentifier, AST.C2 'AST.BeforeSeparator 'AST.AfterSeparator (ASTNS Located [UppercaseIdentifier] 'TypeNK)) + collectAnnotation :: DefinitionBuilder a -> Maybe (LowercaseIdentifier, AST.C2 'AST.BeforeSeparator 'AST.AfterSeparator (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TypeNK)) collectAnnotation decl = case decl of Right (AST.TypeAnnotation (C preColon (VarRef () name)) (C postColon typ)) -> Just (name, C (preColon, postColon) typ) _ -> Nothing - annotations :: Map LowercaseIdentifier (AST.C2 'AST.BeforeSeparator 'AST.AfterSeparator (ASTNS Located [UppercaseIdentifier] 'TypeNK)) + annotations :: Map LowercaseIdentifier (AST.C2 'AST.BeforeSeparator 'AST.AfterSeparator (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TypeNK)) annotations = Map.fromList $ mapMaybe (collectAnnotation . extract) items merge :: DefinitionBuilder a -> Maybe a merge decl = case decl of - Right (AST.Definition (I.Fix (At _ pat)) args comments expr) -> + Right (AST.Definition (I.Fix2 (At _ pat)) args comments expr) -> let annotation = case pat of @@ -770,4 +768,3 @@ instance FromJSON Definition where _ -> fail ("unexpected Definition tag: " <> tag) - diff --git a/elm-format-lib/src/ElmFormat/AST/PublicAST/Module.hs b/elm-format-lib/src/ElmFormat/AST/PublicAST/Module.hs index 47d1cabbd..cfbb42e62 100644 --- a/elm-format-lib/src/ElmFormat/AST/PublicAST/Module.hs +++ b/elm-format-lib/src/ElmFormat/AST/PublicAST/Module.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} module ElmFormat.AST.PublicAST.Module (Module(..), fromModule, toModule) where import ElmFormat.AST.PublicAST.Core @@ -10,10 +7,7 @@ import ElmFormat.AST.PublicAST.Expression import ElmFormat.AST.PublicAST.Type import Reporting.Annotation (Located(At)) import qualified AST.V0_16 as AST -import qualified AST.Module as AST -import qualified AST.Listing as AST import Data.Map.Strict (Map) -import qualified Data.Maybe as Maybe import qualified ElmFormat.ImportInfo as ImportInfo import qualified Data.Map.Strict as Map import qualified Data.Indexed as I @@ -21,7 +15,6 @@ import AST.MatchReferences (fromMatched, matchReferences) import Data.Text (Text) import qualified Data.Either as Either import qualified Data.Text as Text -import Data.Maybe (fromMaybe) data Module @@ -31,42 +24,59 @@ data Module , body :: List (MaybeF LocatedIfRequested TopLevelStructure) } -fromModule :: Config -> AST.Module [UppercaseIdentifier] (ASTNS Located [UppercaseIdentifier] 'TopLevelNK) -> Module +fromModule :: Config -> I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ModuleNK -> Module fromModule config = \case - modu@(AST.Module _ maybeHeader _ (C _ imports) body) -> + I.Fix2 (At _ modu@(AST.Module _ maybeHeader _ (C _ imports) body)) -> let - header = - Maybe.fromMaybe AST.defaultHeader maybeHeader + name = + case maybeHeader of + Nothing -> + [UppercaseIdentifier "Main"] - (AST.Header _ (C _ name) _ _) = header + Just (I.Fix2 (At _ (AST.ModuleHeader _ (C _ name) _ _))) -> + name importInfo = - ImportInfo.fromModule mempty modu + ImportInfo.fromModule mempty (I.hmap (I.fold2 (I.Fix . extract)) modu) normalize = mapNs (fromMatched []) . matchReferences importInfo in Module (ModuleName name) - (Map.mapWithKey (\m (C comments i) -> fromImportMethod m i) $ Map.mapKeys ModuleName imports) - (fromTopLevelStructures config $ normalize body) + (Map.mapWithKey (\m (C comments i) -> fromImportMethod m (I.fold2 (I.Fix . extract) i)) $ Map.mapKeys ModuleName imports) + (fromModuleBody config $ normalize body) -toModule :: Module -> AST.Module [UppercaseIdentifier] (ASTNS Identity [UppercaseIdentifier] 'TopLevelNK) +toModule :: Module -> I.Fix (ASTNS [UppercaseIdentifier]) 'ModuleNK toModule (Module (ModuleName name) imports body) = -- TODO: remove this placeholder - AST.Module + I.Fix $ AST.Module [] - (Just $ AST.Header + (Just $ I.Fix $ AST.ModuleHeader AST.Normal (C ([], []) name) Nothing Nothing ) - (noRegion Nothing) + Nothing (C [] $ Map.mapKeys (\(ModuleName ns) -> ns) $ C [] . toImportMethod <$> imports) - (f $ AST.TopLevel $ mconcat $ fmap (toTopLevelStructures . extract) body) - where - f = I.Fix . Identity + (toModuleBody body) + + +fromModuleBody :: + Config + -> I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ModuleBodyNK + -> List (MaybeF LocatedIfRequested TopLevelStructure) +fromModuleBody config = \case + I.Fix2 (At _ (AST.ModuleBody decls)) -> + fromTopLevelStructures config decls + +toModuleBody :: + List (MaybeF LocatedIfRequested TopLevelStructure) + -> I.Fix (ASTNS [UppercaseIdentifier]) 'ModuleBodyNK +toModuleBody decls = + I.Fix $ AST.ModuleBody $ foldMap (toTopLevelStructures . extract) decls + instance ToJSON Module where toJSON = undefined @@ -93,8 +103,8 @@ data Import } deriving (Generic) -fromImportMethod :: ModuleName -> AST.ImportMethod -> Import -fromImportMethod moduleName (AST.ImportMethod alias (C comments exposing)) = +fromImportMethod :: ModuleName -> I.Fix (ASTNS [UppercaseIdentifier]) 'ImportMethodNK -> Import +fromImportMethod moduleName (I.Fix (AST.ImportMethod alias (C comments (I.Fix (AST.ModuleListing exposing))))) = let as_ = case alias of @@ -103,16 +113,16 @@ fromImportMethod moduleName (AST.ImportMethod alias (C comments exposing)) = in Import as_ exposing -toImportMethod :: Import -> AST.ImportMethod +toImportMethod :: Import -> I.Fix (ASTNS [UppercaseIdentifier]) 'ImportMethodNK toImportMethod (Import alias exposing) = - AST.ImportMethod + I.Fix $ AST.ImportMethod (case alias of ModuleName [single] -> Just $ C ([], []) single _ -> Nothing ) - (C ([], []) exposing) + (C ([], []) $ I.Fix $ AST.ModuleListing exposing) instance ToJSON Import where toEncoding = genericToEncoding defaultOptions @@ -140,17 +150,17 @@ data TopLevelStructure | Comment_tls Comment | TODO_TopLevelStructure String -fromTopLevelStructures :: Config -> ASTNS Located [UppercaseIdentifier] 'TopLevelNK -> List (MaybeF LocatedIfRequested TopLevelStructure) -fromTopLevelStructures config (I.Fix (At _ (AST.TopLevel decls))) = +fromTopLevelStructures :: Config -> List (AST.TopLevelStructure (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TopLevelDeclarationNK)) -> List (MaybeF LocatedIfRequested TopLevelStructure) +fromTopLevelStructures config decls = let toDefBuilder :: AST.TopLevelStructure - (ASTNS Located [UppercaseIdentifier] 'TopLevelDeclarationNK) -> MaybeF LocatedIfRequested (DefinitionBuilder TopLevelStructure) + (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TopLevelDeclarationNK) -> MaybeF LocatedIfRequested (DefinitionBuilder TopLevelStructure) toDefBuilder decl = - case fmap I.unFix decl of + case fmap I.unFix2 decl of AST.Entry (At region entry) -> JustF $ fromLocated config $ At region $ case entry of - AST.CommonDeclaration (I.Fix (At _ def)) -> + AST.CommonDeclaration (I.Fix2 (At _ def)) -> Right def AST.TypeAlias c1 (C (c2, c3) (AST.NameWithArgs name args)) (C c4 t) -> @@ -175,19 +185,19 @@ fromTopLevelStructures config (I.Fix (At _ (AST.TopLevel decls))) = in mkDefinitions config DefinitionStructure $ fmap toDefBuilder decls -toTopLevelStructures :: TopLevelStructure -> List (AST.TopLevelStructure (ASTNS Identity [UppercaseIdentifier] 'TopLevelDeclarationNK)) +toTopLevelStructures :: TopLevelStructure -> List (AST.TopLevelStructure (I.Fix (ASTNS [UppercaseIdentifier]) 'TopLevelDeclarationNK)) toTopLevelStructures = \case DefinitionStructure def -> - AST.Entry . I.Fix . Identity . AST.CommonDeclaration <$> fromDefinition def + AST.Entry . I.Fix . AST.CommonDeclaration <$> fromDefinition def TypeAlias name parameters typ -> - pure $ AST.Entry $ I.Fix $ Identity $ AST.TypeAlias + pure $ AST.Entry $ I.Fix $ AST.TypeAlias [] (C ([], []) (AST.NameWithArgs name (fmap (C []) parameters))) (C [] $ toRawAST typ) CustomType name parameters variants -> - pure $ AST.Entry $ I.Fix $ Identity $ AST.Datatype + pure $ AST.Entry $ I.Fix $ AST.Datatype (C ([], []) (AST.NameWithArgs name (fmap (C []) parameters))) (Either.fromRight undefined $ AST.fromCommentedList (C ([], [], Nothing) . fromCustomTypeVariant <$> variants)) diff --git a/elm-format-lib/src/ElmFormat/AST/PublicAST/Pattern.hs b/elm-format-lib/src/ElmFormat/AST/PublicAST/Pattern.hs index ceb2fe915..9af3881c3 100644 --- a/elm-format-lib/src/ElmFormat/AST/PublicAST/Pattern.hs +++ b/elm-format-lib/src/ElmFormat/AST/PublicAST/Pattern.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -Wno-orphans #-} module ElmFormat.AST.PublicAST.Pattern (Pattern(..), mkListPattern) where @@ -8,6 +6,8 @@ import ElmFormat.AST.PublicAST.Reference import qualified AST.V0_16 as AST import qualified Data.Either as Either import qualified ElmFormat.AST.PublicAST.Core as Core +import qualified Data.Indexed as I +import Reporting.Annotation (Located(At)) data Pattern @@ -62,7 +62,7 @@ instance ToPublicAST 'PatternNK where AST.OpPattern _ -> error "PublicAST: OpPattern is not supported in Elm 0.19" - AST.DataPattern (namespace, tag) args -> + AST.DataPattern (I.Fix2 (At _ (AST.CtorRef_ (namespace, tag)))) args -> DataPattern (mkReference $ TagRef namespace tag) (fromRawAST config . (\(C comments a) -> a) <$> args) @@ -104,7 +104,7 @@ instance ToPublicAST 'PatternNK where (fromRawAST config pat) instance FromPublicAST 'PatternNK where - toRawAST' = \case + toRawAST' = I.Fix . \case AnythingPattern -> AST.Anything @@ -121,7 +121,7 @@ instance FromPublicAST 'PatternNK where case toRef constructor of TagRef ns tag -> AST.DataPattern - (ns, tag) + (I.Fix $ AST.CtorRef_ (ns, tag)) (C [] . toRawAST <$> arguments) ref -> diff --git a/elm-format-lib/src/ElmFormat/AST/PublicAST/Type.hs b/elm-format-lib/src/ElmFormat/AST/PublicAST/Type.hs index 6e6406e90..c2ce04fb4 100644 --- a/elm-format-lib/src/ElmFormat/AST/PublicAST/Type.hs +++ b/elm-format-lib/src/ElmFormat/AST/PublicAST/Type.hs @@ -1,6 +1,4 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -Wno-orphans #-} module ElmFormat.AST.PublicAST.Type (Type_(..), CustomTypeVariant(..), mkCustomTypeVariant, fromCustomTypeVariant) where @@ -13,6 +11,8 @@ import qualified Data.ReversedList as ReversedList import Data.ReversedList (Reversed) import qualified Data.Either as Either import Data.Maybe (fromMaybe) +import Data.List.NonEmpty (NonEmpty) +import Reporting.Annotation (Located(At)) data Type_ @@ -26,7 +26,7 @@ data Type_ { name_tv :: LowercaseIdentifier } | TupleType - { terms :: List (LocatedIfRequested Type_) -- At least two items + { terms :: NonEmpty (LocatedIfRequested Type_) -- At least two items } | RecordType { base :: Maybe LowercaseIdentifier @@ -45,7 +45,7 @@ instance ToPublicAST 'TypeNK where AST.UnitType comments -> UnitType - AST.TypeConstruction (AST.NamedConstructor ( namespace, name )) args forceMultine -> + AST.TypeConstruction (AST.NamedConstructor (I.Fix2 (At _ (AST.TypeRef_ ( namespace, name ))))) args forceMultine -> TypeReference name (ModuleName namespace) @@ -58,7 +58,7 @@ instance ToPublicAST 'TypeNK where TypeVariable name AST.TypeParens (C comments t) -> - fromRawAST' config (extract $ I.unFix t) + fromRawAST' config (extract $ I.unFix2 t) AST.TupleType terms multiline -> TupleType @@ -91,13 +91,13 @@ instance ToPublicAST 'TypeNK where (ReversedList.toList acc, last) instance FromPublicAST 'TypeNK where - toRawAST' = \case + toRawAST' = I.Fix . \case UnitType -> AST.UnitType [] TypeReference name (ModuleName namespace) args -> AST.TypeConstruction - (AST.NamedConstructor ( namespace, name )) + (AST.NamedConstructor $ I.Fix $ AST.TypeRef_ ( namespace, name )) (C [] . toRawAST <$> args) (AST.ForceMultiline False) @@ -228,13 +228,13 @@ data CustomTypeVariant } deriving (Generic) -mkCustomTypeVariant :: Config -> AST.NameWithArgs UppercaseIdentifier (ASTNS Located [UppercaseIdentifier] 'TypeNK) -> CustomTypeVariant +mkCustomTypeVariant :: Config -> AST.NameWithArgs UppercaseIdentifier (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TypeNK) -> CustomTypeVariant mkCustomTypeVariant config (AST.NameWithArgs name args) = CustomTypeVariant name ((\(C c a) -> fromRawAST config a) <$> args) -fromCustomTypeVariant :: CustomTypeVariant -> AST.NameWithArgs UppercaseIdentifier (ASTNS Identity [UppercaseIdentifier] 'TypeNK) +fromCustomTypeVariant :: CustomTypeVariant -> AST.NameWithArgs UppercaseIdentifier (I.Fix (ASTNS [UppercaseIdentifier]) 'TypeNK) fromCustomTypeVariant = \case CustomTypeVariant name parameterTypes -> AST.NameWithArgs diff --git a/elm-format-lib/src/ElmFormat/AST/Shared.hs b/elm-format-lib/src/ElmFormat/AST/Shared.hs index a9a32b76c..970202bf2 100644 --- a/elm-format-lib/src/ElmFormat/AST/Shared.hs +++ b/elm-format-lib/src/ElmFormat/AST/Shared.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} module ElmFormat.AST.Shared where @@ -16,7 +14,7 @@ import qualified Data.Char as Char -} -type List a = [a] +type List = [] newtype LowercaseIdentifier = @@ -45,10 +43,21 @@ instance Monoid c => Applicative (Commented c) where pure = C mempty liftA2 f (C ca a) (C cb b) = C (ca <> cb) (f a b) +instance Foldable (Commented c) where + foldMap f (C _ a) = f a + +instance Traversable (Commented c) where + sequenceA (C c1 fa) = C c1 <$> fa + instance Coapplicative (Commented c) where extract (C _ a) = a {-# INLINE extract #-} +instance Monoid c => Monad (Commented c) where + (C c1 a) >>= f = + C (c1 <> c2) b + where (C c2 b) = f a + data IntRepresentation = DecimalInt diff --git a/elm-format-lib/src/ElmFormat/AST/TransformChain.hs b/elm-format-lib/src/ElmFormat/AST/TransformChain.hs new file mode 100644 index 000000000..0842ed69d --- /dev/null +++ b/elm-format-lib/src/ElmFormat/AST/TransformChain.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE Rank2Types #-} + +module ElmFormat.AST.TransformChain (TransformChain, Carrier, map, mapMaybe, fold2,fold) where + +import Prelude hiding (map) +import qualified Data.Indexed as I + +{-| This module helps with combining multiple AST transformations into a single transformation that can be applied in a single pass. + +Importantly, if any of the transformations in the chain result in a change, +then the entire chain will be applied to the new result, ensuring that the entire +output is fully processed. +-} + + +type TransformChain a = Carrier a -> Carrier a + +newtype Carrier a = + Carry { unCarry :: Either a a } + + +map :: Eq a => (a -> a) -> Carrier a -> Carrier a +map _ (Carry (Left a)) = Carry (Left a) +map f (Carry (Right a)) = + Carry $ + case f a of + new | new == a -> Right a + new -> Left new + + +{-| Use this over `map` when possible, because returning `Nothing` means we don't have to do an equals check on the result. +-} +mapMaybe :: Eq a => (a -> Maybe a) -> Carrier a -> Carrier a +mapMaybe _ (Carry (Left a)) = Carry (Left a) +mapMaybe f (Carry (Right a)) = + Carry $ + case f a of + Nothing -> Right a + Just new | new == a -> Right a + Just new -> Left new + + +fold :: I.HFunctor f => + (forall j. Carrier (I.Fix f j) -> Carrier (I.Fix f j)) + -> I.Fix f i -> I.Fix f i +fold transform = + I.foldTransform (unCarry . transform . Carry . Right . I.Fix) + + +fold2 :: I.HFunctor f => Functor ann => + (forall j. Carrier (I.Fix2 ann f j) -> Carrier (I.Fix2 ann f j)) + -> I.Fix2 ann f i -> I.Fix2 ann f i +fold2 transform = + I.foldTransform2 (unCarry . transform . Carry . Right . I.Fix2) diff --git a/elm-format-lib/src/ElmFormat/ImportInfo.hs b/elm-format-lib/src/ElmFormat/ImportInfo.hs index 1a00ec929..4b0e11917 100644 --- a/elm-format-lib/src/ElmFormat/ImportInfo.hs +++ b/elm-format-lib/src/ElmFormat/ImportInfo.hs @@ -1,11 +1,8 @@ module ElmFormat.ImportInfo (ImportInfo(..), fromModule, fromImports) where import AST.V0_16 -import AST.Listing (Listing(..), CommentedMap) import Elm.Utils ((|>)) -import AST.Module (Module, ImportMethod(..), DetailedListing(..)) -import qualified AST.Module import Data.Coapplicative import qualified Data.Bimap as Bimap import qualified Data.Map.Strict as Dict @@ -13,6 +10,8 @@ import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified ElmFormat.KnownContents as KnownContents import ElmFormat.KnownContents (KnownContents) +import qualified AST.V0_16 as AST +import qualified Data.Indexed as I data ImportInfo ns = ImportInfo @@ -27,26 +26,26 @@ data ImportInfo ns = fromModule :: KnownContents - -> Module [UppercaseIdentifier] decl + -> AST p (I.Fix (AST p)) 'ModuleNK -> ImportInfo [UppercaseIdentifier] fromModule knownContents modu = - fromImports knownContents (fmap extract $ extract $ AST.Module.imports $ modu) + fromImports knownContents (fmap (I.unFix . extract) $ extract $ AST.imports modu) fromImports :: KnownContents - -> Dict.Map [UppercaseIdentifier] ImportMethod + -> Dict.Map [UppercaseIdentifier] (AST p (I.Fix (AST p)) 'ImportMethodNK) -> ImportInfo [UppercaseIdentifier] fromImports knownContents rawImports = let - defaultImports :: Dict.Map [UppercaseIdentifier] ImportMethod + defaultImports :: Dict.Map [UppercaseIdentifier] (AST p (I.Fix (AST p)) 'ImportMethodNK) defaultImports = Dict.fromList $ fmap (\(m, i) -> (fmap UppercaseIdentifier m, ImportMethod Nothing (C ([], []) i))) - [ ( [ "Basics" ], OpenListing (C ([], []) ()) ) - , ( [ "List" ], ClosedListing ) + [ ( [ "Basics" ], I.Fix $ ModuleListing $ OpenListing (C ([], []) ()) ) + , ( [ "List" ], I.Fix $ ModuleListing ClosedListing ) , ( [ "Maybe" ] - , ExplicitListing + , I.Fix $ ModuleListing $ ExplicitListing (DetailedListing mempty mempty $ Dict.fromList [ ( UppercaseIdentifier "Maybe" @@ -82,16 +81,17 @@ fromImports knownContents rawImports = ] _ -> KnownContents.get moduleName knownContents |> Maybe.fromMaybe [] - getExposed moduleName (ImportMethod _ (C _ listing)) = + getExposed :: [UppercaseIdentifier] -> AST p (I.Fix (AST p)) 'ImportMethodNK -> Dict.Map LocalName [UppercaseIdentifier] + getExposed moduleName (ImportMethod _ (C _ (I.Fix (ModuleListing listing)))) = Dict.fromList $ fmap (flip (,) moduleName) $ case listing of ClosedListing -> [] OpenListing _ -> moduleContents moduleName ExplicitListing details _ -> - (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) + (fmap VarName $ Dict.keys $ AST.values details) + <> (fmap TypeName $ Dict.keys $ AST.types details) + <> (fmap CtorName $ foldMap (getCtorListings . extract . extract) $ Dict.elems $ AST.types details) getCtorListings :: Listing (CommentedMap name ()) -> [name] getCtorListings = \case @@ -108,7 +108,7 @@ fromImports knownContents rawImports = aliases = let getAlias importMethod = - case AST.Module.alias importMethod of + case AST.alias importMethod of Just (C _ alias) -> Just [alias] @@ -125,7 +125,7 @@ fromImports knownContents rawImports = |> Bimap.fromList noAlias importMethod = - case AST.Module.alias importMethod of + case AST.alias importMethod of Just _ -> False Nothing -> True @@ -136,7 +136,8 @@ fromImports knownContents rawImports = ambiguous = Dict.empty - exposesAll (ImportMethod _ (C _ listing)) = + exposesAll :: AST p (I.Fix (AST p)) 'ImportMethodNK -> Bool + exposesAll (ImportMethod _ (C _ (I.Fix (ModuleListing listing)))) = case listing of ExplicitListing _ _ -> False OpenListing _ -> True diff --git a/elm-format-lib/src/ElmFormat/Normalize.hs b/elm-format-lib/src/ElmFormat/Normalize.hs new file mode 100644 index 000000000..446c44879 --- /dev/null +++ b/elm-format-lib/src/ElmFormat/Normalize.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE QuantifiedConstraints #-} + +module ElmFormat.Normalize (shallow, deepMonad) where + +{-| Applies AST normalizations that are considered part +elm-format's "formatting". +-} + +import AST.V0_16 +import AST.Structure +import qualified Data.Indexed as I +import Control.Monad (join) +import Control.Applicative (liftA2) +import ElmVersion (ElmVersion) +import qualified ElmVersion + + +{-| Simply uses `join` to combine layers -} +deepMonad :: forall annf nk. + Traversable annf => Monad annf => + ElmVersion + -> I.Fix2 annf (ASTNS [UppercaseIdentifier]) nk + -> I.Fix2 annf (ASTNS [UppercaseIdentifier]) nk +deepMonad elmVersion = I.fold2 go + where + go :: annf (AST (VariableNamespace [UppercaseIdentifier]) (I.Fix2 annf (ASTNS [UppercaseIdentifier])) i) + -> I.Fix2 annf (ASTNS [UppercaseIdentifier]) i + go original = + I.Fix2 $ join $ fmap (shallow elmVersion) original + + +-- {-| Will use `normalized <> original` at each layer. -} +-- deepSemigroup :: forall annf ns nk. +-- Traversable annf => Monad annf => +-- (forall j. Semigroup (annf (AST (VariableNamespace ns) (I.Fix2 annf (ASTNS ns)) j))) => + +-- (forall a. Show a => Show (annf a)) => +-- Show ns => + +-- I.Fix2 annf (ASTNS ns) nk -> I.Fix2 annf (ASTNS ns) nk +-- deepSemigroup = I.fold2 go +-- where +-- go :: annf (AST (VariableNamespace ns) (I.Fix2 annf (ASTNS ns)) i) +-- -> I.Fix2 annf (ASTNS ns) i +-- go original = trace "\n" $ +-- I.Fix2 $ join $ traceShowId $ +-- fmap (<> original) $ traceShowId $ +-- fmap shallow $ traceShowId $ original + + +-- {-| Will use `normalized <|> original` at each layer. -} +-- deepAlternative :: forall annf ns nk. +-- (Traversable annf) => Monad annf => +-- Alternative annf => +-- (forall j. Show (annf (AST (VariableNamespace ns) (I.Fix2 annf (ASTNS ns)) j))) => + +-- I.Fix2 annf (ASTNS ns) nk -> I.Fix2 annf (ASTNS ns) nk +-- deepAlternative = I.fold2 (go . traceShowId) +-- where +-- go :: annf (AST (VariableNamespace ns) (I.Fix2 annf (ASTNS ns)) i) +-- -> I.Fix2 annf (ASTNS ns) i +-- go original = +-- I.Fix2 $ join $ +-- fmap (<|> original) $ +-- fmap (shallow) original + + +-- deep :: forall annf ns nk. (Traversable annf, Monad annf) => +-- (forall a. (a -> annf a) -> annf a -> annf (annf a)) -> +-- I.Fix2 annf (ASTNS ns) nk -> I.Fix2 annf (ASTNS ns) nk +-- deep merge = I.fold2 go +-- where +-- go :: annf (AST (VariableNamespace ns) (I.Fix2 annf (ASTNS ns)) i) +-- -> I.Fix2 annf (ASTNS ns) i +-- go original = +-- -- I.Fix2 $ maybe _ _ $ _ $ fmap (fromMaybe original) $ fmap sequenceA +-- -- -- fromMaybe original $ sequenceA +-- -- (fmap (getCompose . shallow) original) +-- I.Fix2 $ join $ merge shallow original + + +shallow :: + forall annf nk. + (Traversable annf, Monad annf) => + ElmVersion + -> ASTNS [UppercaseIdentifier] (I.Fix2 annf (ASTNS [UppercaseIdentifier])) nk + -> annf (ASTNS [UppercaseIdentifier] (I.Fix2 annf (ASTNS [UppercaseIdentifier])) nk) +shallow elmVersion = \case + App left [] _ -> + I.unFix2 left + + -- Remove parens in function arguments when the comments can be merged with the surrounding whitespace + App left args multiline -> do + -- TODO: This currently joins `annf` for _all_ the args, but ideally we only want to join for ones that we want to simplify and leave the others untouched. + newArgs <- gg args + pure $ App left newArgs multiline + where + gg :: + List (C1 'BeforeTerm (I.Fix2 annf (ASTNS ns) 'ExpressionNK)) + -> annf (List (C1 'BeforeTerm (I.Fix2 annf (ASTNS ns) 'ExpressionNK))) + gg [] = pure [] + gg (next : rest) = + liftA2 (:) (removeParens next) (gg rest) + + removeParens :: + C1 'BeforeTerm (I.Fix2 annf (ASTNS ns) 'ExpressionNK) + -> annf (C1 'BeforeTerm (I.Fix2 annf (ASTNS ns) 'ExpressionNK)) + removeParens (C pre e) = + fmap (fmap (I.Fix2 . pure) . (\(c, e') -> C (pre ++ c) e')) + ((>>= matchPreCommentedParens) (I.unFix2 e)) + + matchPreCommentedParens :: + ASTNS1 annf ns 'ExpressionNK + -> annf (Comments, ASTNS1 annf ns 'ExpressionNK) + matchPreCommentedParens = \case + Parens (C (pre', []) e) -> (,) pre' <$> I.unFix2 e + other -> pure ([], other) + + -- Convert literal range syntax if it's not allowed + Range left right -> + if ElmVersion.syntax_0_18_disallowLiteralRange elmVersion + then + case (left, right) of + -- No comments after terms, so we can skip adding parens + (C (preLeft, []) left', C (preRight, []) right') -> + pure $ App + (mkVarRef "List" "range") + [ C preLeft left' + , C preRight right' + ] + (FAJoinFirst JoinAll) + + _ -> + pure $ App + (mkVarRef "List" "range") + [ C [] $ I.Fix2 $ pure $ Parens left + , C [] $ I.Fix2 $ pure $ Parens right + ] + (FAJoinFirst JoinAll) + else + pure $ Range left right + + ast -> pure ast + + +mkVarRef :: Applicative m => String -> String -> I.Fix2 m (ASTNS [UppercaseIdentifier]) 'ExpressionNK +mkVarRef ns1 name = + I.Fix2 $ pure $ VarExpr $ I.Fix2 $ pure $ VarRef_ $ VarRef [UppercaseIdentifier ns1] (LowercaseIdentifier name) diff --git a/elm-format-lib/src/ElmFormat/Parse.hs b/elm-format-lib/src/ElmFormat/Parse.hs index aa1fb9687..ec4596b8d 100644 --- a/elm-format-lib/src/ElmFormat/Parse.hs +++ b/elm-format-lib/src/ElmFormat/Parse.hs @@ -1,11 +1,8 @@ -{-# LANGUAGE DataKinds #-} module ElmFormat.Parse where import Elm.Utils ((|>)) import AST.V0_16 -import AST.Module (Module) -import AST.Structure ( ASTNS ) import Data.Coapplicative import qualified Data.Text as Text import ElmVersion ( ElmVersion ) @@ -13,18 +10,23 @@ import qualified Parse.Literal import qualified Parse.Parse as Parse import qualified Reporting.Error.Syntax as Syntax import qualified Reporting.Result as Result -import Reporting.Annotation (Located) -import qualified AST.Module as Module import qualified Parse.Module import Data.Text (Text) +import Parse.IParser (IParser, ParsedAST) +import qualified Parse.Helpers -parse :: ElmVersion -> Text -> Result.Result () Syntax.Error (Module [UppercaseIdentifier] (ASTNS Located [UppercaseIdentifier] 'TopLevelNK)) +parse :: ElmVersion -> Text -> Result.Result () Syntax.Error (ParsedAST 'ModuleNK) parse elmVersion input = Text.unpack input |> Parse.parseModule elmVersion +parse' :: IParser a -> Text -> Either [Syntax.Error] a +parse' parser text = + toEither $ Parse.parse (Text.unpack text) parser + + toMaybe :: Result.Result a b c -> Maybe c toMaybe res = case res of @@ -43,9 +45,14 @@ toEither res = Left $ map extract b -import' :: ElmVersion -> Text -> Either [Syntax.Error] Module.UserImport -import' elmVersion text = - toEither $ Parse.parse (Text.unpack text) (Parse.Module.import' elmVersion) +import' :: ElmVersion -> Text -> Either [Syntax.Error] (C1 'BeforeTerm [UppercaseIdentifier], ParsedAST 'ImportMethodNK) +import' elmVersion = + parse' (Parse.Module.import' elmVersion) + + +ref :: ElmVersion -> Text -> Either [Syntax.Error] (Ref [UppercaseIdentifier]) +ref elmVersion = + parse' (Parse.Helpers.var elmVersion) -- TODO: can this be removed? diff --git a/elm-format-lib/src/ElmFormat/Render/Box.hs b/elm-format-lib/src/ElmFormat/Render/Box.hs index 955836864..cc05c1eb6 100644 --- a/elm-format-lib/src/ElmFormat/Render/Box.hs +++ b/elm-format-lib/src/ElmFormat/Render/Box.hs @@ -1,30 +1,23 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} module ElmFormat.Render.Box where import Elm.Utils ((|>)) -import Box +import Box ( Line, identifier, punc, space, render ) import ElmVersion (ElmVersion(..)) import AST.V0_16 -import qualified AST.Module import AST.Structure -import qualified AST.Listing import qualified Cheapskate.Types as Markdown import qualified Control.Monad as Monad import qualified Data.Char as Char import Data.Coapplicative import qualified Data.Foldable as Foldable -import Data.Functor.Identity import qualified Data.Indexed as I import qualified Data.List as List -import Data.List.Extra import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, maybeToList) +import Data.Maybe (fromMaybe, maybeToList, catMaybes) import qualified Data.Maybe as Maybe import Data.ReversedList (Reversed) import qualified Data.ReversedList as ReversedList @@ -34,51 +27,29 @@ import Data.Text (Text) import qualified Data.Text as Text import ElmFormat.ImportInfo (ImportInfo) import qualified ElmFormat.ImportInfo as ImportInfo +import qualified ElmFormat.Normalize as Normalize import qualified ElmFormat.Render.ElmStructure as ElmStructure import qualified ElmFormat.Render.Markdown import qualified ElmVersion import qualified Parse.Parse as Parse -import qualified Reporting.Annotation as A import qualified Reporting.Result as Result import Text.Printf (printf) - -pleaseReport'' :: String -> String -> String -pleaseReport'' what details = - -- TODO: include version in the message - "" - - -pleaseReport' :: String -> String -> Line -pleaseReport' what details = - keyword $ pleaseReport'' what details +import ElmFormat.Render.ElmStructure (Elm, parens, keyword) +import qualified Data.Fix as Fix +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Either.Extra +import Data.Bifunctor (bimap) +import Data.Map.Strict (Map) -pleaseReport :: String -> String -> Box +pleaseReport :: String -> String -> a pleaseReport what details = - line $ pleaseReport' what details - - -surround :: Char -> Char -> Box -> Box -surround left right b = - let - left' = punc [left] - right' = punc [right] - in - case b of - SingleLine b' -> - line $ row [ left', b', right' ] - _ -> - stack1 - [ prefix left' b - , line right' - ] - - -parens :: Box -> Box -parens = surround '(' ')' + -- TODO: include version in the message + error $ "" -formatBinary :: Bool -> Box -> [ ( Bool, Comments, Box, Box ) ] -> Box +formatBinary :: Bool -> Elm -> [ ( Bool, Comments, Elm, Elm ) ] -> Elm formatBinary multiline left ops = case ops of [] -> @@ -88,10 +59,7 @@ formatBinary multiline left ops = if isLeftPipe then ElmStructure.forceableSpaceSepOrIndented multiline (ElmStructure.spaceSepOrStack left $ - concat - [ Maybe.maybeToList $ formatComments comments - , [op] - ] + maybeToList (formatComments comments) ++ [op] ) [formatBinary multiline next rest] else @@ -104,8 +72,8 @@ formatBinary multiline left ops = splitWhere :: (a -> Bool) -> [a] -> [[a]] splitWhere predicate list = let - merge acc result = - ReversedList.push (ReversedList.toList acc) result + merge acc = + ReversedList.push (ReversedList.toList acc) step (acc,result) next = if predicate next then @@ -169,13 +137,13 @@ removeDuplicates input = else (ReversedList.push next acc, Set.insert next seen) -sortVars :: Bool -> Set (C2 before after AST.Listing.Value) -> [[String]] -> ([[C2 before after AST.Listing.Value]], Comments) +sortVars :: Bool -> Set (C2 before after ListingValue) -> [[String]] -> ([[C2 before after ListingValue]], Comments) sortVars forceMultiline fromExposing fromDocs = let - varOrder :: Commented c AST.Listing.Value -> (Int, String) - varOrder (C _ (AST.Listing.OpValue (SymbolIdentifier name))) = (1, name) - varOrder (C _ (AST.Listing.Union (C _ (UppercaseIdentifier name)) _)) = (2, name) - varOrder (C _ (AST.Listing.Value (LowercaseIdentifier name))) = (3, name) + varOrder :: Commented c ListingValue -> (Int, String) + varOrder (C _ (OpValue (SymbolIdentifier name))) = (1, name) + varOrder (C _ (Union (C _ (UppercaseIdentifier name)) _)) = (2, name) + varOrder (C _ (Value (LowercaseIdentifier name))) = (3, name) listedInDocs = fromDocs @@ -189,9 +157,9 @@ sortVars forceMultiline fromExposing fromDocs = |> Set.toList |> List.sortOn varOrder - varName (C _ (AST.Listing.Value (LowercaseIdentifier name))) = name - varName (C _ (AST.Listing.OpValue (SymbolIdentifier name))) = name - varName (C _ (AST.Listing.Union (C _ (UppercaseIdentifier name)) _)) = name + varName (C _ (Value (LowercaseIdentifier name))) = name + varName (C _ (OpValue (SymbolIdentifier name))) = name + varName (C _ (Union (C _ (UppercaseIdentifier name)) _)) = name varSetToMap set = Set.toList set @@ -202,7 +170,7 @@ sortVars forceMultiline fromExposing fromDocs = varSetToMap fromExposing allFromDocs = - Set.fromList $ fmap varName $ concat listedInDocs + Set.fromList $ varName <$> concat listedInDocs inDocs x = Set.member (varName x) allFromDocs @@ -218,30 +186,36 @@ sortVars forceMultiline fromExposing fromDocs = |> concat in if List.null listedInDocs && forceMultiline - then ( fmap (\x -> [x]) remainingFromExposing, commentsFromReorderedVars ) - else ( listedInDocs ++ if List.null remainingFromExposing then [] else [ remainingFromExposing ], commentsFromReorderedVars ) + then ( pure <$> remainingFromExposing, commentsFromReorderedVars ) + else ( listedInDocs ++ [remainingFromExposing | not (List.null remainingFromExposing)], commentsFromReorderedVars ) -formatModuleHeader :: Coapplicative annf => ElmVersion -> Bool -> AST.Module.Module [UppercaseIdentifier] (ASTNS annf [UppercaseIdentifier] 'TopLevelNK) -> [Box] -formatModuleHeader elmVersion addDefaultHeader modu = - let +formatModuleHeader :: ElmVersion -> Bool -> I.Fix (ASTNS [UppercaseIdentifier]) 'ModuleNK -> (Maybe Elm, Maybe Elm, (Maybe Elm, List Elm)) +formatModuleHeader elmVersion addDefaultHeader (I.Fix modu@(Module _ header docs imports (I.Fix (ModuleBody decls)))) = + let + defaultHeader = + I.Fix $ ModuleHeader + Normal + (C ([], []) [UppercaseIdentifier "Main"]) + Nothing + Nothing + maybeHeader = if addDefaultHeader - then Just (AST.Module.header modu |> Maybe.fromMaybe AST.Module.defaultHeader) - else AST.Module.header modu + then Just (Maybe.fromMaybe defaultHeader header) + else header refName (VarRef _ (LowercaseIdentifier name)) = name refName (TagRef _ (UppercaseIdentifier name)) = name refName (OpRef (SymbolIdentifier name)) = name - varName (C _ (AST.Listing.Value (LowercaseIdentifier name))) = name - varName (C _ (AST.Listing.OpValue (SymbolIdentifier name))) = name - varName (C _ (AST.Listing.Union (C _ (UppercaseIdentifier name)) _)) = name + varName (C _ (Value (LowercaseIdentifier name))) = name + varName (C _ (OpValue (SymbolIdentifier name))) = name + varName (C _ (Union (C _ (UppercaseIdentifier name)) _)) = name documentedVars :: [[String]] documentedVars = - AST.Module.docs modu - |> extract + docs |> fmap Foldable.toList |> Maybe.fromMaybe [] |> concatMap extractDocs @@ -252,7 +226,7 @@ formatModuleHeader elmVersion addDefaultHeader modu = extractDocs block = case block of Markdown.ElmDocs vars -> - fmap (fmap (refName . textToRef)) vars + fmap (refName . textToRef) <$> vars _ -> [] textToRef :: Text -> Ref [UppercaseIdentifier] @@ -264,43 +238,42 @@ formatModuleHeader elmVersion addDefaultHeader modu = ['(', a, b, ')'] -> OpRef (SymbolIdentifier [a, b]) s -> VarRef [] (LowercaseIdentifier s) - definedVars :: Set (C2 before after AST.Listing.Value) + definedVars :: Set (C2 before after ListingValue) definedVars = - AST.Module.body modu - |> (extract . I.unFix) - |> (\(TopLevel decls) -> decls) + decls |> concatMap extractVarName |> fmap (C ([], [])) |> Set.fromList + exportsList :: Listing DetailedListing exportsList = case - AST.Module.exports (maybeHeader |> Maybe.fromMaybe AST.Module.defaultHeader) + exports (I.unFix $ fromMaybe defaultHeader maybeHeader) of - Just (C _ e) -> e - Nothing -> AST.Listing.ClosedListing + Just (C _ (I.Fix (ModuleListing e))) -> e + Nothing -> ClosedListing - detailedListingToSet :: AST.Listing.Listing AST.Module.DetailedListing -> Set (C2 before after AST.Listing.Value) - detailedListingToSet (AST.Listing.OpenListing _) = Set.empty - detailedListingToSet AST.Listing.ClosedListing = Set.empty - detailedListingToSet (AST.Listing.ExplicitListing (AST.Module.DetailedListing values operators types) _) = + detailedListingToSet :: Listing DetailedListing -> Set (C2 before after ListingValue) + detailedListingToSet (OpenListing _) = Set.empty + detailedListingToSet ClosedListing = Set.empty + detailedListingToSet (ExplicitListing (DetailedListing values operators types) _) = Set.unions - [ Map.assocs values |> fmap (\(name, C c ()) -> C c (AST.Listing.Value name)) |> Set.fromList - , Map.assocs operators |> fmap (\(name, C c ()) -> C c (AST.Listing.OpValue name)) |> Set.fromList - , Map.assocs types |> fmap (\(name, C c (C preListing listing)) -> C c (AST.Listing.Union (C preListing name) listing)) |> Set.fromList + [ Map.assocs values |> fmap (\(name, C c ()) -> C c (Value name)) |> Set.fromList + , Map.assocs operators |> fmap (\(name, C c ()) -> C c (OpValue name)) |> Set.fromList + , Map.assocs types |> fmap (\(name, C c (C preListing listing)) -> C c (Union (C preListing name) listing)) |> Set.fromList ] - detailedListingIsMultiline :: AST.Listing.Listing a -> Bool - detailedListingIsMultiline (AST.Listing.ExplicitListing _ isMultiline) = isMultiline + detailedListingIsMultiline :: Listing a -> Bool + detailedListingIsMultiline (ExplicitListing _ isMultiline) = isMultiline detailedListingIsMultiline _ = False varsToExpose = - case AST.Module.exports =<< maybeHeader of + case exports . I.unFix =<< maybeHeader of Nothing -> if all null documentedVars then definedVars else definedVars |> Set.filter (\v -> Set.member (varName v) documentedVarsSet) - Just (C _ e) -> detailedListingToSet e + Just (C _ (I.Fix (ModuleListing e))) -> detailedListingToSet e sortedExports = sortVars @@ -308,25 +281,26 @@ formatModuleHeader elmVersion addDefaultHeader modu = varsToExpose documentedVars - extractVarName :: Coapplicative annf => TopLevelStructure (ASTNS annf ns 'TopLevelDeclarationNK) -> [AST.Listing.Value] + extractVarName :: TopLevelStructure (I.Fix (ASTNS ns) 'TopLevelDeclarationNK) -> [ListingValue] extractVarName decl = - case fmap (extract . I.unFix) decl of + case I.unFix <$> decl of DocComment _ -> [] BodyComment _ -> [] - Entry (PortAnnotation (C _ (LowercaseIdentifier name)) _ _) -> [ AST.Listing.Value (LowercaseIdentifier name) ] + Entry (PortAnnotation (C _ (LowercaseIdentifier name)) _ _) -> [ Value (LowercaseIdentifier name) ] Entry (CommonDeclaration def) -> - case extract $ I.unFix def of + case I.unFix def of Definition pat _ _ _ -> - case extract $ I.unFix pat of - VarPattern (LowercaseIdentifier name) -> [ AST.Listing.Value (LowercaseIdentifier name) ] - RecordPattern fields -> fmap (AST.Listing.Value . extract) fields + case I.unFix pat of + VarPattern (LowercaseIdentifier name) -> [ Value (LowercaseIdentifier name) ] + RecordPattern fields -> Value . extract <$> fields _ -> [] _ -> [] - Entry (Datatype (C _ (NameWithArgs (UppercaseIdentifier name) _)) _) -> [ AST.Listing.Union (C [] (UppercaseIdentifier name)) (AST.Listing.OpenListing (C ([], []) ()))] - Entry (TypeAlias _ (C _ (NameWithArgs (UppercaseIdentifier name) _)) _) -> [ AST.Listing.Union (C [] (UppercaseIdentifier name)) AST.Listing.ClosedListing ] + Entry (Datatype (C _ (NameWithArgs (UppercaseIdentifier name) _)) _) -> [ Union (C [] (UppercaseIdentifier name)) (OpenListing (C ([], []) ()))] + Entry (TypeAlias _ (C _ (NameWithArgs (UppercaseIdentifier name) _)) _) -> [ Union (C [] (UppercaseIdentifier name)) ClosedListing ] Entry _ -> [] - formatModuleLine' header@(AST.Module.Header srcTag name moduleSettings exports) = + formatModuleLine' :: AST (VariableNamespace ns) (I.Fix (ASTNS ns)) 'ModuleHeaderNK -> Elm + formatModuleLine' header_@(ModuleHeader srcTag name moduleSettings exports) = let (preExposing, postExposing) = case exports of @@ -334,217 +308,157 @@ formatModuleHeader elmVersion addDefaultHeader modu = Just (C (pre, post) _) -> (pre, post) in case elmVersion of - Elm_0_16 -> - formatModuleLine_0_16 header - - Elm_0_17 -> - formatModuleLine elmVersion sortedExports srcTag name moduleSettings preExposing postExposing - - Elm_0_18 -> - formatModuleLine elmVersion sortedExports srcTag name moduleSettings preExposing postExposing - - Elm_0_19 -> - formatModuleLine elmVersion sortedExports srcTag name moduleSettings preExposing postExposing + Elm_0_16 -> + formatModuleLine_0_16 (I.Fix header_) - docs = - fmap (formatDocComment elmVersion (ImportInfo.fromModule mempty modu)) $ extract $ AST.Module.docs modu + Elm_0_17 -> + formatModuleLine sortedExports srcTag name moduleSettings preExposing postExposing - imports = - formatImports elmVersion modu - in - List.intercalate [ blankLine ] $ concat - [ maybeToList $ fmap (return . formatModuleLine') maybeHeader - , maybeToList $ fmap return docs - , if null imports - then [] - else [ imports ] - ] + Elm_0_18 -> + formatModuleLine sortedExports srcTag name moduleSettings preExposing postExposing + Elm_0_19 -> + formatModuleLine sortedExports srcTag name moduleSettings preExposing postExposing -formatImports :: ElmVersion -> AST.Module.Module [UppercaseIdentifier] decl -> [Box] -formatImports elmVersion modu = - let - (C comments imports) = - AST.Module.imports modu + docs_ = + formatDocComment elmVersion (ImportInfo.fromModule mempty modu) <$> docs in - [ formatComments comments - |> maybeToList - , imports + ( formatModuleLine' . I.unFix <$> maybeHeader + , docs_ + , formatImports imports + ) + + +formatImports :: + C1 'BeforeTerm (Map [UppercaseIdentifier] (C1 'BeforeTerm (I.Fix (ASTNS ns) 'ImportMethodNK))) + -> (Maybe Elm, [Elm]) +formatImports (C comments imports_) = + ( formatComments comments + , imports_ |> Map.assocs - |> fmap (\(name, C pre method) -> formatImport elmVersion (C pre name, method)) - ] - |> List.filter (not . List.null) - |> List.intersperse [blankLine] - |> concat + |> fmap (\(name, C pre method) -> formatImport (C pre name, I.unFix method)) + ) -formatModuleLine_0_16 :: AST.Module.Header -> Box -formatModuleLine_0_16 header = +formatModuleLine_0_16 :: I.Fix (ASTNS ns) 'ModuleHeaderNK -> Elm +formatModuleLine_0_16 (I.Fix header) = let - elmVersion = Elm_0_16 - - exports = - case AST.Module.exports header of - Just (C _ value) -> value - Nothing -> AST.Listing.OpenListing (C ([], []) ()) + exports_ = + case exports header of + Just (C _ (I.Fix (ModuleListing value))) -> value + Nothing -> OpenListing (C ([], []) ()) formatExports = - case formatListing (formatDetailedListing elmVersion) exports of + case formatListing formatDetailedListing exports_ of Just listing -> listing _ -> pleaseReport "UNEXPECTED MODULE DECLARATION" "empty listing" whereComments = - case AST.Module.exports header of + case exports header of Nothing -> ([], []) Just (C (pre, post) _) -> (pre, post) whereClause = - formatCommented (C whereComments $ line $ keyword "where") + formatCommented (C whereComments $ keyword "where") in - case - ( formatCommented $ (line . formatQualifiedUppercaseIdentifier elmVersion) <$> AST.Module.name header - , formatExports - , whereClause - ) - of - (SingleLine name', SingleLine exports', SingleLine where') -> - line $ row - [ keyword "module" - , space - , name' - , row [ space, exports' ] - , space - , where' - ] - (name', exports', _) -> - stack1 - [ line $ keyword "module" - , indent name' - , indent exports' - , indent whereClause - ] + ElmStructure.spaceSepOrIndented + (keyword "module") + [ formatCommented $ formatUppercaseIdentifier' <$> name header + , formatExports + , whereClause + ] formatModuleLine :: - ElmVersion - -> ([[C2 before after AST.Listing.Value]], Comments) - -> AST.Module.SourceTag + ([[C2 before after ListingValue]], Comments) + -> SourceTag -> C2 before after [UppercaseIdentifier] - -> Maybe (C2 before after AST.Module.SourceSettings) + -> Maybe (C2 before after SourceSettings) -> Comments -> Comments - -> Box -formatModuleLine elmVersion (varsToExpose, extraComments) srcTag name moduleSettings preExposing postExposing = - let - tag = - case srcTag of - AST.Module.Normal -> - line $ keyword "module" - - AST.Module.Port comments -> - ElmStructure.spaceSepOrIndented - (formatTailCommented (C comments $ line $ keyword "port")) - [ line $ keyword "module" ] - - AST.Module.Effect comments -> - ElmStructure.spaceSepOrIndented - (formatTailCommented (C comments $ line $ keyword "effect")) - [ line $ keyword "module" ] - - exports = - case varsToExpose of - [] -> line $ keyword "(..)" - [oneGroup] -> - oneGroup - |> fmap (formatCommented . fmap (formatVarValue elmVersion)) - |> ElmStructure.group' False "(" "," (maybeToList (formatComments extraComments)) ")" False - _ -> - varsToExpose - |> fmap (formatCommented . fmap (ElmStructure.group False "" "," "" False . fmap (formatVarValue elmVersion)) . sequenceA) - |> ElmStructure.group' False "(" "," (maybeToList (formatComments extraComments)) ")" True - - formatSetting (k, v) = - formatRecordPair elmVersion "=" (line . formatUppercaseIdentifier elmVersion) (k, v, False) - - formatSettings settings = - map formatSetting settings - |> ElmStructure.group True "{" "," "}" False + -> Elm +formatModuleLine (varsToExpose, extraComments) srcTag name moduleSettings preExposing postExposing = + let + tag = + case srcTag of + Normal -> + keyword "module" + + Port comments -> + ElmStructure.spaceSepOrIndented + (formatTailCommented (C comments $ keyword "port")) + [ keyword "module" ] + + Effect comments -> + ElmStructure.spaceSepOrIndented + (formatTailCommented (C comments $ keyword "effect")) + [ keyword "module" ] + + exports = + case varsToExpose of + [] -> keyword "(..)" + [oneGroup] -> + ElmStructure.group' False "(" "," (formatComments extraComments) ")" False $ + formatCommented . fmap formatVarValue <$> oneGroup + _ -> + ElmStructure.group' False "(" "," (formatComments extraComments) ")" True $ + formatCommented . fmap (ElmStructure.group False "" "," "" False . fmap formatVarValue) . sequenceA <$> varsToExpose - whereClause = - moduleSettings - |> fmap (formatKeywordCommented "where" . fmap formatSettings) - |> fmap (\x -> [x]) - |> Maybe.fromMaybe [] - - nameClause = - case - ( tag - , formatCommented $ fmap (line . formatQualifiedUppercaseIdentifier elmVersion) name - ) - of - (SingleLine tag', SingleLine name') -> - line $ row - [ tag' - , space - , name' - ] + formatSetting (k, v) = + formatRecordPair "=" (k, formatUppercaseIdentifier [] <$> v, False) - (tag', name') -> - stack1 - [ tag' - , indent name' - ] + formatSettings settings = + ElmStructure.group True "{" "," "}" False $ + formatSetting <$> settings + + whereClause = + maybeToList $ + formatKeywordCommented "where" . fmap formatSettings <$> moduleSettings + + nameClause = + ElmStructure.spaceSepOrIndented tag + [formatCommented $ formatUppercaseIdentifier' <$> name] in ElmStructure.spaceSepOrIndented (ElmStructure.spaceSepOrIndented nameClause - (whereClause ++ [formatCommented (C (preExposing, postExposing) $ line $ keyword "exposing")]) + (whereClause ++ [formatCommented (C (preExposing, postExposing) $ keyword "exposing")]) ) [ exports ] -formatModule :: Coapplicative annf => ElmVersion -> Bool -> Int -> AST.Module.Module [UppercaseIdentifier] (ASTNS annf [UppercaseIdentifier] 'TopLevelNK) -> Box -formatModule elmVersion addDefaultHeader spacing modu = +formatModule :: ElmVersion -> Bool -> Int -> I.Fix (ASTNS [UppercaseIdentifier]) 'ModuleNK -> Elm +formatModule elmVersion addDefaultHeader spacing modu' = let - initialComments' = - case AST.Module.initialComments modu of - [] -> - [] - comments -> - (fmap formatComment comments) - ++ [ blankLine, blankLine ] + modu = I.unFix $ I.fold2Identity (Normalize.shallow elmVersion) modu' + + (ModuleBody decls) = I.unFix $ moduleBody modu spaceBeforeBody = - case extract $ I.unFix $ AST.Module.body modu of - TopLevel [] -> 0 - TopLevel (BodyComment _ : _) -> spacing + 1 - TopLevel _ -> spacing - - decls = - case extract $ I.unFix $ AST.Module.body modu of - TopLevel decls -> decls + case decls of + [] -> 0 + (BodyComment _ : _) -> spacing + 1 + _ -> spacing in - stack1 $ - concat - [ initialComments' - , formatModuleHeader elmVersion addDefaultHeader modu - , List.replicate spaceBeforeBody blankLine - , maybeToList $ formatModuleBody spacing elmVersion (ImportInfo.fromModule mempty modu) decls - ] + ElmStructure.module' + (formatComment <$> initialComments modu) + (formatModuleHeader elmVersion addDefaultHeader (I.Fix modu)) + spaceBeforeBody + (formatModuleBody spacing elmVersion (ImportInfo.fromModule mempty modu) decls) -formatModuleBody :: forall annf. Coapplicative annf => Int -> ElmVersion -> ImportInfo [UppercaseIdentifier] -> [TopLevelStructure (ASTNS annf [UppercaseIdentifier] 'TopLevelDeclarationNK)] -> Maybe Box +formatModuleBody :: Int -> ElmVersion -> ImportInfo [UppercaseIdentifier] -> [TopLevelStructure (I.Fix (ASTNS [UppercaseIdentifier]) 'TopLevelDeclarationNK)] -> Maybe Elm formatModuleBody linesBetween elmVersion importInfo body = let - entryType :: ASTNS annf ns 'TopLevelDeclarationNK -> BodyEntryType + entryType :: I.Fix (ASTNS ns) 'TopLevelDeclarationNK -> BodyEntryType entryType adecl = - case extract $ I.unFix adecl of + case I.unFix adecl of CommonDeclaration def -> - case extract $ I.unFix def of + case I.unFix def of Definition pat _ _ _ -> - case extract $ I.unFix pat of + case I.unFix pat of VarPattern name -> BodyNamed $ VarRef () name @@ -576,7 +490,7 @@ formatModuleBody linesBetween elmVersion importInfo body = BodyFixity in formatTopLevelBody linesBetween elmVersion importInfo $ - fmap (fmap $ \b -> (entryType b, formatDeclaration elmVersion importInfo b)) body + fmap (\b -> (entryType b, formatDeclaration elmVersion importInfo b)) <$> body data BodyEntryType @@ -589,56 +503,61 @@ formatTopLevelBody :: Int -> ElmVersion -> ImportInfo [UppercaseIdentifier] - -> [TopLevelStructure (BodyEntryType, Box)] - -> Maybe Box + -> [TopLevelStructure (BodyEntryType, Elm)] + -> Maybe Elm formatTopLevelBody linesBetween elmVersion importInfo body = - let - extraLines n = - List.replicate n blankLine - - spacer a b = - case (declarationType (fmap fst a), declarationType (fmap fst 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 = - intersperseMap (\a b -> extraLines $ spacer a b) + case body of + [] -> Nothing + first:rest -> + Just $ + stackWithSpacing + (\a b -> topLevelSpacer linesBetween (fst <$> a) (fst <$> b)) (formatTopLevelStructure elmVersion importInfo . fmap snd) - body - in - case boxes of - [] -> Nothing - _ -> Just $ stack1 boxes + first rest -data ElmCodeBlock annf ns - = DeclarationsCode [TopLevelStructure (ASTNS annf ns 'TopLevelDeclarationNK)] - | ExpressionsCode [TopLevelStructure (C0Eol (ASTNS annf ns 'ExpressionNK))] - | ModuleCode (AST.Module.Module ns (ASTNS annf ns 'TopLevelNK)) - -convertElmCodeBlock :: Functor ann => (forall x. ann x -> ann' x) -> ElmCodeBlock ann ns -> ElmCodeBlock ann' ns -convertElmCodeBlock f = \case - 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) +stackWithSpacing :: (a -> a -> Int) -> (a -> Elm) -> a -> [a] -> Elm +stackWithSpacing getSpacing format first rest = + let + spacing = + zipWith getSpacing (first:rest) rest + in + ElmStructure.stackWithVariableSpacing + (format first) + (zip spacing (format <$> rest)) + + +{-| How many blank lines should go between two given top-level declarations. +-} +topLevelSpacer :: Int -> TopLevelStructure BodyEntryType -> TopLevelStructure BodyEntryType -> Int +topLevelSpacer linesBetween a b = + case (declarationType a, declarationType 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 + + +data ElmCodeBlock ns + = DeclarationsCode [TopLevelStructure (I.Fix (ASTNS ns) 'TopLevelDeclarationNK)] + | ExpressionsCode [TopLevelStructure (C0Eol (I.Fix (ASTNS ns) 'ExpressionNK))] + | ModuleCode (I.Fix (ASTNS ns) 'ModuleNK) -- TODO: there must be an existing haskell function that does this, right? @@ -652,40 +571,40 @@ firstOf options value = Nothing -> firstOf rest value -formatDocComment :: ElmVersion -> ImportInfo [UppercaseIdentifier] -> Markdown.Blocks -> Box +formatDocComment :: ElmVersion -> ImportInfo [UppercaseIdentifier] -> Markdown.Blocks -> Elm formatDocComment elmVersion importInfo blocks = let - parse :: String -> Maybe (ElmCodeBlock Identity [UppercaseIdentifier]) + parse :: String -> Maybe (ElmCodeBlock [UppercaseIdentifier]) parse source = source |> firstOf - [ fmap DeclarationsCode . Result.toMaybe . Parse.parseDeclarations elmVersion - , fmap ExpressionsCode . Result.toMaybe . Parse.parseExpressions elmVersion - , fmap ModuleCode . Result.toMaybe . Parse.parseModule elmVersion + [ fmap (DeclarationsCode . fmap (fmap $ I.fold2 $ I.Fix . extract)) + . Result.toMaybe . Parse.parseDeclarations elmVersion + , fmap (ExpressionsCode . fmap (fmap $ fmap $ I.fold2 $ I.Fix . extract)) + . Result.toMaybe . Parse.parseExpressions elmVersion + , fmap (ModuleCode . I.fold2 (I.Fix . extract)) + . Result.toMaybe . Parse.parseModule elmVersion ] - |> fmap (convertElmCodeBlock (pure . extract)) format :: - (Applicative annf, Coapplicative annf) => - ElmCodeBlock annf [UppercaseIdentifier] -> String + ElmCodeBlock [UppercaseIdentifier] -> String format result = case result of ModuleCode modu -> formatModule elmVersion False 1 modu - |> (Text.unpack . Box.render) + |> (Text.unpack . Box.render . Fix.cata ElmStructure.render) DeclarationsCode declarations -> formatModuleBody 1 elmVersion importInfo declarations - |> fmap (Text.unpack . Box.render) + |> fmap (Text.unpack . Box.render . Fix.cata ElmStructure.render) |> fromMaybe "" ExpressionsCode expressions -> expressions - |> fmap (fmap $ fmap $ I.convert (Identity . extract)) |> fmap (fmap $ formatEolCommented . fmap (syntaxParens SyntaxSeparated . formatExpression elmVersion importInfo)) |> fmap (fmap $ (,) BodyUnnamed) |> formatTopLevelBody 1 elmVersion importInfo - |> fmap (Text.unpack . Box.render) + |> fmap (Text.unpack . Box.render . Fix.cata ElmStructure.render) |> fromMaybe "" content :: String @@ -703,273 +622,114 @@ formatDocComment elmVersion importInfo blocks = _ -> block in - formatDocCommentString content - + ElmStructure.docComment "{-|" "-}" + (Text.lines $ Text.pack content) -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 :: ElmVersion -> AST.Module.UserImport -> Box -formatImport elmVersion (name@(C _ rawName), method) = +formatImport :: (Commented Comments [UppercaseIdentifier], AST p (I.Fix (AST p)) 'ImportMethodNK) -> Elm +formatImport (name@(C _ rawName), method) = let + name' = + formatPreCommented $ formatUppercaseIdentifier' <$> name + requestedAs = - case AST.Module.alias method of + case alias method of Just (C _ aliasName) | [aliasName] == rawName -> Nothing other -> other as = requestedAs - |> fmap (formatImportClause - (Just . line . formatUppercaseIdentifier elmVersion) - "as") + |> fmap (formatImportClause "as" . fmap (Just . formatUppercaseIdentifier [])) |> Monad.join exposing = - formatImportClause - (formatListing (formatDetailedListing elmVersion)) - "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 + formatImportClause "exposing" + (formatListing formatDetailedListing . (\(ModuleListing l) -> l) . I.unFix <$> exposedVars method) + + formatImportClause :: Text -> C2 beforeKeyword afterKeyword (Maybe Elm) -> Maybe Elm + formatImportClause keyw = \case C ([], []) Nothing -> - 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 $ ElmStructure.spaceSepOrIndented + (formatPreCommented (C preKeyword $ keyword keyw)) + [ formatPreCommented (C postKeyword listing') ] _ -> - Just $ pleaseReport "UNEXPECTED IMPORT" "import clause comments with no clause" + pleaseReport "UNEXPECTED IMPORT" "import clause comments with no clause" in - case - ( formatPreCommented $ fmap (line . formatQualifiedUppercaseIdentifier elmVersion) name - , as - , exposing - ) - of - ( SingleLine name', Just (SingleLine as'), Just (SingleLine exposing') ) -> - line $ row - [ keyword "import" - , space - , name' - , space - , as' - , space - , exposing' - ] - - (SingleLine name', Just (SingleLine as'), Nothing) -> - line $ row - [ keyword "import" - , space - , name' - , space - , as' - ] + ElmStructure.import' name' as exposing - (SingleLine name', Nothing, Just (SingleLine exposing')) -> - line $ row - [ keyword "import" - , space - , name' - , space - , exposing' - ] - (SingleLine name', Nothing, Nothing) -> - line $ row - [ keyword "import" - , space - , name' - ] - - ( SingleLine name', Just (SingleLine as'), Just exposing' ) -> - stack1 - [ line $ row - [ keyword "import" - , space - , name' - , space - , as' - ] - , indent exposing' - ] - - ( SingleLine name', Just as', Just exposing' ) -> - stack1 - [ line $ row - [ keyword "import" - , space - , name' - ] - , indent as' - , indent exposing' - ] - - ( SingleLine name', Nothing, Just exposing' ) -> - stack1 - [ line $ row - [ keyword "import" - , space - , name' - ] - , indent exposing' - ] - - ( name', Just as', Just exposing' ) -> - stack1 - [ line $ keyword "import" - , indent name' - , indent $ indent as' - , indent $ indent exposing' - ] - - ( name', Nothing, Just exposing' ) -> - stack1 - [ line $ keyword "import" - , indent name' - , indent $ indent exposing' - ] - - ( name', Just as', Nothing ) -> - stack1 - [ line $ keyword "import" - , indent name' - , indent $ indent as' - ] - - ( name', Nothing, Nothing ) -> - stack1 - [ line $ keyword "import" - , indent name' - ] - - -formatListing :: (a -> [Box]) -> AST.Listing.Listing a -> Maybe Box +formatListing :: (a -> [Elm]) -> Listing a -> Maybe Elm formatListing format listing = case listing of - AST.Listing.ClosedListing -> + ClosedListing -> Nothing - AST.Listing.OpenListing (C comments ()) -> - Just $ parens $ formatCommented $ C comments $ line $ keyword ".." + OpenListing (C comments ()) -> + Just $ parens $ formatCommented $ C comments $ keyword ".." - AST.Listing.ExplicitListing vars multiline -> + ExplicitListing vars multiline -> case format vars of [] -> Nothing vars' -> Just $ ElmStructure.group False "(" "," ")" multiline vars' -formatDetailedListing :: ElmVersion -> AST.Module.DetailedListing -> [Box] -formatDetailedListing elmVersion listing = +formatDetailedListing :: DetailedListing -> [Elm] +formatDetailedListing listing = concat [ formatCommentedMap - (\name () -> AST.Listing.OpValue name) - (formatVarValue elmVersion) - (AST.Module.operators listing) + (\name () -> OpValue name) + formatVarValue + (operators listing) , formatCommentedMap - (\name (C inner listing_) -> AST.Listing.Union (C inner name) listing_) - (formatVarValue elmVersion) - (AST.Module.types listing) + (\name (C inner listing_) -> Union (C inner name) listing_) + formatVarValue + (types listing) , formatCommentedMap - (\name () -> AST.Listing.Value name) - (formatVarValue elmVersion) - (AST.Module.values listing) + (\name () -> Value name) + formatVarValue + (values listing) ] -formatCommentedMap :: (k -> v -> a) -> (a -> Box) -> AST.Listing.CommentedMap k v -> [Box] +formatCommentedMap :: (k -> v -> a) -> (a -> Elm) -> CommentedMap k v -> [Elm] formatCommentedMap construct format values = let format' (k, C c v) = formatCommented $ C c (format $ construct k v) in - values - |> Map.assocs - |> fmap format' + format' <$> Map.assocs values -formatVarValue :: ElmVersion -> AST.Listing.Value -> Box -formatVarValue elmVersion aval = +formatVarValue :: ListingValue -> Elm +formatVarValue aval = case aval of - AST.Listing.Value val -> - line $ formatLowercaseIdentifier elmVersion [] val - - AST.Listing.OpValue (SymbolIdentifier name) -> - line $ identifier $ "(" ++ name ++ ")" - - AST.Listing.Union name listing -> - case - ( formatListing - (formatCommentedMap - (\name_ () -> name_) - (line . formatUppercaseIdentifier elmVersion) - ) - listing - , formatTailCommented $ fmap (line . formatUppercaseIdentifier elmVersion) name - , (\(C c _) -> c) name - , elmVersion - ) - of - (Just _, _, _, Elm_0_19) -> - formatTailCommented $ - fmap (\n -> line $ row [ formatUppercaseIdentifier elmVersion n, keyword "(..)" ]) - name - - (Just (SingleLine listing'), SingleLine name', [], _) -> - line $ row - [ name' - , listing' - ] - - (Just (SingleLine listing'), SingleLine name', _, _) -> - line $ row - [ name' - , space - , listing' - ] + Value val -> + formatLowercaseIdentifier [] val - (Just listing', name', _, _) -> - stack1 - [ name' - , indent $ listing' - ] + OpValue op -> + formatSymbolIdentifierInParens op - (Nothing, name', _, _) -> - name' + Union name listing -> + let + listing' = + formatListing + (formatCommentedMap + (\name_ () -> name_) + (formatUppercaseIdentifier []) + ) + listing + in + ElmStructure.unionListing + (formatTailCommented $ formatUppercaseIdentifier [] <$> name) + ([] /= (\(C c _) -> c) name) + listing' -formatTopLevelStructure :: ElmVersion -> ImportInfo [UppercaseIdentifier] -> TopLevelStructure Box -> Box +formatTopLevelStructure :: ElmVersion -> ImportInfo [UppercaseIdentifier] -> TopLevelStructure Elm -> Elm formatTopLevelStructure elmVersion importInfo topLevelStructure = case topLevelStructure of DocComment docs -> @@ -982,11 +742,21 @@ formatTopLevelStructure elmVersion importInfo topLevelStructure = entry +data FormatResult (nk :: NodeKind) where + FormattedCtorRef :: SyntaxContext -> Elm -> FormatResult 'CtorRefNK + FormattedExpression :: SyntaxContext -> Elm -> FormatResult 'ExpressionNK + FormattedPattern :: SyntaxContext -> Elm -> FormatResult 'PatternNK + + +formatAst :: ElmVersion -> ImportInfo [UppercaseIdentifier] -> I.Fix (ASTNS [UppercaseIdentifier]) nk -> FormatResult nk +formatAst elmVersion importInfo = + I.fold (formatAstNode elmVersion importInfo) + + formatCommonDeclaration :: - Coapplicative annf => - ElmVersion -> ImportInfo [UppercaseIdentifier] -> ASTNS annf [UppercaseIdentifier] 'CommonDeclarationNK -> Box + ElmVersion -> ImportInfo [UppercaseIdentifier] -> I.Fix (ASTNS [UppercaseIdentifier]) 'CommonDeclarationNK -> Elm formatCommonDeclaration elmVersion importInfo decl = - case extract $ I.unFix $ I.convert (Identity . extract) decl of + case I.unFix decl of Definition name args comments expr -> formatDefinition elmVersion importInfo name args comments expr @@ -995,287 +765,242 @@ formatCommonDeclaration elmVersion importInfo decl = formatDeclaration :: - Coapplicative annf => - ElmVersion -> ImportInfo [UppercaseIdentifier] -> ASTNS annf [UppercaseIdentifier] 'TopLevelDeclarationNK -> Box + ElmVersion -> ImportInfo [UppercaseIdentifier] -> I.Fix (ASTNS [UppercaseIdentifier]) 'TopLevelDeclarationNK -> Elm formatDeclaration elmVersion importInfo decl = - case extract $ I.unFix $ I.convert (Identity . extract) decl of + case I.unFix decl of CommonDeclaration def -> formatCommonDeclaration elmVersion importInfo def Datatype nameWithArgs tags -> let ctor (NameWithArgs tag args') = - case allSingles $ map (formatPreCommented .fmap (typeParens ForCtor . formatType elmVersion)) args' of - Right args'' -> - line $ row $ List.intersperse space $ (formatUppercaseIdentifier elmVersion tag):args'' - Left [] -> - line $ formatUppercaseIdentifier elmVersion tag - Left args'' -> - stack1 - [ line $ formatUppercaseIdentifier elmVersion tag - , stack1 args'' - |> indent - ] + ElmStructure.spaceSepOrIndented + (formatUppercaseIdentifier [] tag) + (formatPreCommented . fmap (typeParens ForCtor . formatType elmVersion) <$> args') + + leftSide = + ElmStructure.spaceSepOrIndented + (keyword "type") + [ formatCommented $ formatNameWithArgs <$> nameWithArgs + ] + + variants = + case formatOpenCommentedList $ ctor <$> tags of + [] -> pleaseReport "UNEXPECTED CUSTOM TYPE DECLARATION" "No variants" + first:rest -> + ElmStructure.spaceSepOrPrefix (keyword "=") first + : (ElmStructure.spaceSepOrPrefix (keyword "|") <$> rest) in - case - formatOpenCommentedList $ fmap ctor tags - of - [] -> error "List can't be empty" - first:rest -> - case formatCommented $ fmap (formatNameWithArgs elmVersion) nameWithArgs of - SingleLine nameWithArgs' -> - stack1 - [ line $ row - [ keyword "type" - , space - , nameWithArgs' - ] - , first - |> prefix (row [punc "=", space]) - |> andThen (map (prefix (row [punc "|", space])) rest) - |> indent - ] - nameWithArgs' -> - stack1 - [ line $ keyword "type" - , indent nameWithArgs' - , first - |> prefix (row [punc "=", space]) - |> andThen (map (prefix (row [punc "|", space])) rest) - |> indent - ] + ElmStructure.stackIndent leftSide variants TypeAlias preAlias nameWithArgs typ -> ElmStructure.definition "=" True - (line $ keyword "type") - [ formatPreCommented (C preAlias $ line $ keyword "alias") - , formatCommented $ fmap (formatNameWithArgs elmVersion) nameWithArgs + (keyword "type") + [ formatPreCommented (C preAlias $ keyword "alias") + , formatCommented $ formatNameWithArgs <$> nameWithArgs ] - (formatPreCommentedStack $ fmap (typeParens NotRequired . formatType elmVersion) typ) + (formatPreCommentedStack $ typeParens NotRequired . formatType elmVersion <$> typ) PortAnnotation name typeComments typ -> ElmStructure.definition ":" False - (line $ keyword "port") - [ formatCommented $ fmap (line . formatLowercaseIdentifier elmVersion []) name ] + (keyword "port") + [ formatCommented $ formatLowercaseIdentifier [] <$> name ] (formatCommented' typeComments $ typeParens NotRequired $ formatType elmVersion typ) PortDefinition_until_0_16 name bodyComments expr -> ElmStructure.definition "=" True - (line $ keyword "port") - [formatCommented $ fmap (line . formatLowercaseIdentifier elmVersion []) name] + (keyword "port") + [formatCommented $ formatLowercaseIdentifier [] <$> name] (formatCommented' bodyComments $ syntaxParens SyntaxSeparated $ formatExpression elmVersion importInfo expr) - Fixity_until_0_18 assoc precedenceComments precedence nameComments name -> - case - ( formatCommented' nameComments $ line $ formatInfixVar elmVersion name - , formatCommented' precedenceComments $ line $ literal $ show precedence - ) - of - (SingleLine name', SingleLine precedence') -> - line $ row - [ case assoc of - L -> keyword "infixl" - R -> keyword "infixr" - N -> keyword "infix" - , space - , precedence' - , space - , name' - ] - _ -> - pleaseReport "TODO" "multiline fixity declaration" + Fixity_until_0_18 assoc precedenceComments precedence nameComments (I.Fix (VarRef_ name)) -> + ElmStructure.spaceSepOrIndented + (formatInfixAssociativity_0_18 assoc) + [ formatCommented' precedenceComments $ formatInfixPrecedence precedence + , formatCommented' nameComments $ formatInfixVar name + ] Fixity assoc precedence name value -> - let - formatAssoc a = - case a of - L -> keyword "left " - R -> keyword "right" - N -> keyword "non " - in ElmStructure.spaceSepOrIndented - (line $ keyword "infix") - [ formatPreCommented $ fmap (line . formatAssoc) assoc - , formatPreCommented $ fmap (line . literal . show) precedence - , formatCommented $ fmap (line . formatSymbolIdentifierInParens) name - , line $ keyword "=" - , formatPreCommented $ fmap (line . identifier . formatVarName elmVersion) value + (keyword "infix") + [ formatPreCommented $ formatInfixAssociativity_0_19 <$> assoc + , formatPreCommented $ formatInfixPrecedence <$> precedence + , formatCommented $ formatSymbolIdentifierInParens <$> name + , keyword "=" + , formatPreCommented $ formatLowercaseIdentifier [] <$> value ] -formatNameWithArgs :: ElmVersion -> NameWithArgs UppercaseIdentifier LowercaseIdentifier -> Box -formatNameWithArgs elmVersion (NameWithArgs name args) = - case allSingles $ fmap (formatPreCommented . fmap (line . formatLowercaseIdentifier elmVersion [])) args of - Right args' -> - line $ row $ List.intersperse space ((formatUppercaseIdentifier elmVersion name):args') - Left args' -> - stack1 $ - [ line $ formatUppercaseIdentifier elmVersion name ] - ++ (fmap indent args') +formatInfixAssociativity_0_18 :: Assoc -> Elm +formatInfixAssociativity_0_18 assoc = + keyword $ + case assoc of + L -> "infixl" + R -> "infixr" + N -> "infix" + + +formatInfixAssociativity_0_19 :: Assoc -> Elm +formatInfixAssociativity_0_19 a = + keyword $ + case a of + L -> "left " + R -> "right" + N -> "non " + + +formatInfixPrecedence :: Int -> Elm +formatInfixPrecedence = + ElmStructure.literal . Text.pack . show + + +formatNameWithArgs :: NameWithArgs UppercaseIdentifier LowercaseIdentifier -> Elm +formatNameWithArgs (NameWithArgs name args) = + ElmStructure.spaceSepOrIndented + (formatUppercaseIdentifier [] name) + (formatPreCommented . fmap (formatLowercaseIdentifier []) <$> args) formatDefinition :: ElmVersion -> ImportInfo [UppercaseIdentifier] - -> ASTNS Identity [UppercaseIdentifier] 'PatternNK - -> [C1 before (ASTNS Identity [UppercaseIdentifier] 'PatternNK)] + -> I.Fix (ASTNS [UppercaseIdentifier]) 'PatternNK + -> [C1 before (I.Fix (ASTNS [UppercaseIdentifier]) 'PatternNK)] -> Comments - -> ASTNS Identity [UppercaseIdentifier] 'ExpressionNK - -> Box + -> I.Fix (ASTNS [UppercaseIdentifier]) 'ExpressionNK + -> Elm formatDefinition elmVersion importInfo name args comments expr = - let - body = - stack1 $ concat - [ map formatComment comments - , [ syntaxParens SyntaxSeparated $ formatExpression elmVersion importInfo expr ] - ] - in + let + body = + ElmStructure.stack1 $ NonEmpty.fromList $ mconcat + [ formatComment <$> comments + , [ syntaxParens SyntaxSeparated $ formatExpression elmVersion importInfo expr ] + ] + in ElmStructure.definition "=" True - (syntaxParens SpaceSeparated $ formatPattern elmVersion name) - (map (\(C x y) -> formatCommented' x $ syntaxParens SpaceSeparated $ formatPattern elmVersion y) args) + (syntaxParens SpaceSeparated $ formatAst elmVersion importInfo name) + (map (\(C x y) -> formatCommented' x $ syntaxParens SpaceSeparated $ formatAst elmVersion importInfo y) args) body formatTypeAnnotation :: - Coapplicative annf => - ElmVersion -> C1 after (Ref ()) -> C1 before (ASTNS annf [UppercaseIdentifier] 'TypeNK) -> Box + ElmVersion -> C1 after (Ref ()) -> C1 before (I.Fix (ASTNS [UppercaseIdentifier]) 'TypeNK) -> Elm formatTypeAnnotation elmVersion name typ = ElmStructure.definition ":" False - (formatTailCommented $ fmap (line . formatVar elmVersion . fmap (\() -> [])) name) + (formatTailCommented $ formatVar . fmap (\() -> []) <$> name) [] - (formatPreCommented $ fmap (typeParens NotRequired . formatType elmVersion) typ) + (formatPreCommented $ typeParens NotRequired . formatType elmVersion <$> typ) -formatPattern :: - Coapplicative annf => - ElmVersion -> ASTNS annf [UppercaseIdentifier] 'PatternNK -> (SyntaxContext, Box) -formatPattern elmVersion apattern = - case extract $ I.unFix apattern of +formatAstNode :: + CtorRef p ~ ([UppercaseIdentifier], UppercaseIdentifier) => + ElmVersion -> ImportInfo [UppercaseIdentifier] -> AST p FormatResult nk -> FormatResult nk +formatAstNode elmVersion importInfo = + \case + CtorRef_ (ns, tag) -> + formatUppercaseIdentifier ns tag + |> + case (elmVersion, ns) of + (Elm_0_16, []) -> + FormattedCtorRef SyntaxSeparated + (Elm_0_16, _:_) -> + FormattedCtorRef SpaceSeparated + _ -> + FormattedCtorRef SyntaxSeparated + Anything -> - (,) SyntaxSeparated $ line $ keyword "_" + FormattedPattern SyntaxSeparated $ keyword "_" UnitPattern comments -> - (,) SyntaxSeparated $ formatUnit '(' ')' comments + FormattedPattern SyntaxSeparated $ formatUnit '(' ')' comments LiteralPattern lit -> - (,) SyntaxSeparated $ formatLiteral elmVersion lit + FormattedPattern SyntaxSeparated $ formatLiteral elmVersion lit VarPattern var -> - (,) SyntaxSeparated $ line $ formatLowercaseIdentifier elmVersion [] var + FormattedPattern SyntaxSeparated $ formatLowercaseIdentifier [] var - OpPattern (SymbolIdentifier name) -> - (,) SyntaxSeparated $ line $ identifier $ "(" ++ name ++ ")" + OpPattern op -> + FormattedPattern SyntaxSeparated $ + formatSymbolIdentifierInParens op ConsPattern first rest -> let formatRight (C (preOp, postOp, eol) term) = ( False , preOp - , line $ punc "::" - , formatC2Eol $ - (fmap $ syntaxParens SpaceSeparated . formatPattern elmVersion) - (C (postOp, [], eol) term) + , keyword "::" + , formatC2Eol $ C (postOp, [], eol) $ syntaxParens SpaceSeparated term ) in - (,) SpaceSeparated $ + FormattedPattern SpaceSeparated $ formatBinary False - (formatEolCommented $ fmap (syntaxParens SpaceSeparated . formatPattern elmVersion) first) + (formatEolCommented $ syntaxParens SpaceSeparated <$> first) (formatRight <$> toCommentedList rest) - DataPattern (ns, tag) [] -> - let - ctor = ns ++ [tag] - in - line (formatQualifiedUppercaseIdentifier elmVersion ctor) - |> - case (elmVersion, ctor) of - (Elm_0_16, [_]) -> - (,) SyntaxSeparated - (Elm_0_16, _) -> - (,) SpaceSeparated - _ -> - (,) SyntaxSeparated + DataPattern (FormattedCtorRef context tag) [] -> + FormattedPattern context tag - DataPattern (ns, tag) patterns -> - let - ctor = ns ++ [tag] - in - (,) SpaceSeparated $ + DataPattern (FormattedCtorRef context tag) (pat0:pats) -> + FormattedPattern SpaceSeparated $ ElmStructure.application (FAJoinFirst JoinAll) - (line $ formatQualifiedUppercaseIdentifier elmVersion ctor) - (fmap (formatPreCommented . fmap (syntaxParens SpaceSeparated . formatPattern elmVersion)) patterns) + tag + (formatPreCommented . fmap (syntaxParens SpaceSeparated) <$> pat0:|pats) PatternParens pattern -> - formatCommented (fmap (syntaxParens SyntaxSeparated . formatPattern elmVersion) pattern) - |> parens - |> (,) SyntaxSeparated + FormattedPattern SyntaxSeparated $ + parens $ formatCommented $ syntaxParens SyntaxSeparated <$> pattern TuplePattern patterns -> - (,) SyntaxSeparated $ - ElmStructure.group True "(" "," ")" False $ fmap (formatCommented . fmap (syntaxParens SyntaxSeparated . formatPattern elmVersion)) patterns + FormattedPattern SyntaxSeparated $ + ElmStructure.group True "(" "," ")" False $ formatCommented . fmap (syntaxParens SyntaxSeparated) <$> patterns EmptyListPattern comments -> - (,) SyntaxSeparated $ + FormattedPattern SyntaxSeparated $ formatUnit '[' ']' comments ListPattern patterns -> - (,) SyntaxSeparated $ - ElmStructure.group True "[" "," "]" False $ fmap (formatCommented . fmap (syntaxParens SyntaxSeparated . formatPattern elmVersion)) patterns + FormattedPattern SyntaxSeparated $ + ElmStructure.group True "[" "," "]" False $ formatCommented . fmap (syntaxParens SyntaxSeparated) <$> patterns EmptyRecordPattern comments -> - (,) SyntaxSeparated $ + FormattedPattern SyntaxSeparated $ formatUnit '{' '}' comments RecordPattern fields -> - (,) SyntaxSeparated $ - ElmStructure.group True "{" "," "}" False $ map (formatCommented . fmap (line . formatLowercaseIdentifier elmVersion [])) fields + FormattedPattern SyntaxSeparated $ + ElmStructure.group True "{" "," "}" False $ formatCommented . fmap (formatLowercaseIdentifier []) <$> fields Alias pattern name -> - (,) SpaceSeparated $ - case - ( formatTailCommented $ fmap (syntaxParens SpaceSeparated . formatPattern elmVersion) pattern - , formatPreCommented $ fmap (line . formatLowercaseIdentifier elmVersion []) name - ) - of - (SingleLine pattern', SingleLine name') -> - line $ row - [ pattern' - , space - , keyword "as" - , space - , name' - ] - - (pattern', name') -> - stack1 - [ pattern' - , line $ keyword "as" - , indent name' + FormattedPattern SpaceSeparated $ + ElmStructure.spaceSepOrStack + (formatTailCommented $ syntaxParens SpaceSeparated <$> pattern) + [ ElmStructure.spaceSepOrIndented + (keyword "as") + [ formatPreCommented $ formatLowercaseIdentifier [] <$> name] ] -formatRecordPair :: ElmVersion -> String -> (v -> Box) -> (C2 before after LowercaseIdentifier, C2 before after v, Bool) -> Box -formatRecordPair elmVersion delim formatValue (C (pre, postK) k, v, forceMultiline) = +formatRecordPair :: Text -> (C2 before after LowercaseIdentifier, C2 before after Elm, Bool) -> Elm +formatRecordPair delim (C (pre, postK) k, v, forceMultiline) = + formatPreCommented $ C pre $ ElmStructure.equalsPair delim forceMultiline - (formatCommented $ line . formatLowercaseIdentifier elmVersion [] <$> C ([], postK) k) - (formatCommented $ fmap formatValue v) - |> C pre - |> formatPreCommented + (formatCommented $ formatLowercaseIdentifier [] <$> C ([], postK) k) + (formatCommented v) -formatPair :: String -> Pair Line Box -> Box +formatPair :: Text -> Pair Elm Elm -> Elm formatPair delim (Pair a b (ForceMultiline forceMultiline)) = ElmStructure.equalsPair delim forceMultiline - (formatTailCommented $ fmap line a) + (formatTailCommented a) (formatPreCommented b) negativeCasePatternWorkaround :: - Coapplicative annf => - ASTNS annf [UppercaseIdentifier] 'PatternNK -> Box -> Box + I.Fix (ASTNS [UppercaseIdentifier]) 'PatternNK -> Elm -> Elm negativeCasePatternWorkaround pattern = - case extract $ I.unFix pattern of + case I.unFix pattern of LiteralPattern (IntNum i _) | i < 0 -> parens LiteralPattern (FloatNum f _) | f < 0 -> parens _ -> id @@ -1288,9 +1013,24 @@ data SyntaxContext | AmbiguousEnd -syntaxParens :: SyntaxContext -> (SyntaxContext, Box) -> Box -syntaxParens outer (inner, box) = - parensIf (needsParensInContext inner outer) box +class UsesSyntaxParens a where + type Context a + parensNeeded :: Context a -> a -> Bool + getBox :: a -> Elm + +instance UsesSyntaxParens (FormatResult 'ExpressionNK) where + type Context (FormatResult 'ExpressionNK) = SyntaxContext + parensNeeded outer (FormattedExpression inner _) = needsParensInContext inner outer + getBox (FormattedExpression _ box) = box + +instance UsesSyntaxParens (FormatResult 'PatternNK) where + type Context (FormatResult 'PatternNK) = SyntaxContext + parensNeeded outer (FormattedPattern inner _) = needsParensInContext inner outer + getBox (FormattedPattern _ box) = box + +syntaxParens :: UsesSyntaxParens a => Context a -> a -> Elm +syntaxParens outer a = + parensIf (parensNeeded outer a) (getBox a) where parensIf True = parens parensIf False = id @@ -1310,261 +1050,141 @@ needsParensInContext inner outer = formatExpression :: ElmVersion -> ImportInfo [UppercaseIdentifier] - -> ASTNS Identity [UppercaseIdentifier] 'ExpressionNK - -> (SyntaxContext, Box) + -> I.Fix (ASTNS [UppercaseIdentifier]) 'ExpressionNK + -> FormatResult 'ExpressionNK formatExpression elmVersion importInfo aexpr = - case extract $ I.unFix aexpr of + case I.unFix aexpr of Literal lit -> - (,) SyntaxSeparated $ formatLiteral elmVersion lit + FormattedExpression SyntaxSeparated $ formatLiteral elmVersion lit - VarExpr v -> - (,) SyntaxSeparated $ line $ formatVar elmVersion v + VarExpr (I.Fix (VarRef_ v)) -> + FormattedExpression SyntaxSeparated $ formatVar v - Range left right multiline -> - case elmVersion of - Elm_0_16 -> (,) SyntaxSeparated $ formatRange_0_17 elmVersion importInfo left right multiline - Elm_0_17 -> (,) SyntaxSeparated $ formatRange_0_17 elmVersion importInfo left right multiline - Elm_0_18 -> formatRange_0_18 elmVersion importInfo left right - Elm_0_19 -> formatRange_0_18 elmVersion importInfo left right + Range left right -> + FormattedExpression SyntaxSeparated $ + ElmStructure.range "[" ".." "]" + (formatCommentedExpression elmVersion importInfo left) + (formatCommentedExpression elmVersion importInfo right) ExplicitList exprs trailing multiline -> - (,) SyntaxSeparated $ - formatSequence '[' ',' (Just ']') + FormattedExpression SyntaxSeparated $ + formatSequenceAsGroup '[' ',' ']' multiline trailing (syntaxParens SyntaxSeparated . formatExpression elmVersion importInfo <$> exprs) Binops left ops multiline -> - (,) InfixSeparated $ - formatBinops elmVersion importInfo left ops multiline + FormattedExpression InfixSeparated $ + formatBinops (formatExpression elmVersion importInfo left) (fmap (formatExpression elmVersion importInfo) <$> ops) multiline - Lambda patterns bodyComments expr multiline -> - (,) AmbiguousEnd $ - case - ( multiline - , allSingles $ fmap (formatPreCommented . fmap (syntaxParens SpaceSeparated . formatPattern elmVersion)) patterns - , bodyComments == [] - , syntaxParens SyntaxSeparated $ formatExpression elmVersion 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' ] - ] + Lambda [] _ _ _ -> + pleaseReport "UNEXPECTED LAMBDA" "no patterns" + + Lambda (pat1:pats) bodyComments expr multiline -> + let + patterns' = + ElmStructure.forceableSpaceSepOrStack1 False + (formatPreCommented . fmap (syntaxParens SpaceSeparated . formatAst elmVersion importInfo) <$> pat1:|pats) + in + FormattedExpression AmbiguousEnd $ + ElmStructure.lambda "\\" "->" multiline + patterns' + (formatComments bodyComments) + (syntaxParens SyntaxSeparated $ formatExpression elmVersion importInfo expr) Unary Negative e -> - (,) SyntaxSeparated $ - prefix (punc "-") $ syntaxParens SpaceSeparated $ formatExpression elmVersion importInfo e -- TODO: This might need something stronger than SpaceSeparated? + FormattedExpression SyntaxSeparated $ + ElmStructure.unary (keyword "-") $ + syntaxParens SpaceSeparated $ formatExpression elmVersion importInfo e -- TODO: This might need something stronger than SpaceSeparated? App left [] _ -> formatExpression elmVersion importInfo left - App left args multiline -> - (,) SpaceSeparated $ + App left (arg0:args) multiline -> + FormattedExpression SpaceSeparated $ ElmStructure.application multiline (syntaxParens InfixSeparated $ formatExpression elmVersion importInfo left) - (fmap (formatPreCommentedExpression elmVersion importInfo SpaceSeparated) args) + (formatPreCommented . fmap (syntaxParens SpaceSeparated . formatExpression elmVersion importInfo) <$> arg0:|args) - If if' elseifs (C elsComments els) -> + If (IfClause cond body) 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 elmVersion importInfo cond - , indent $ formatCommented_ True $ fmap (syntaxParens SyntaxSeparated . formatExpression elmVersion 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 elmVersion importInfo cond - , indent $ formatCommented_ True $ fmap (syntaxParens SyntaxSeparated . formatExpression elmVersion importInfo) body - ] + formatElseIf (C ifComments (IfClause cond' body')) = + ( formatComments ifComments + , formatCommentedExpression elmVersion importInfo cond' + , formatCommented_ True $ syntaxParens SyntaxSeparated . formatExpression elmVersion importInfo <$> body' + ) in - (,) AmbiguousEnd $ - formatIf if' - |> andThen (fmap formatElseIf elseifs) - |> andThen - [ blankLine - , line $ keyword "else" - , indent $ formatCommented_ True $ fmap (syntaxParens SyntaxSeparated . formatExpression elmVersion importInfo) (C (elsComments, []) els) - ] + FormattedExpression AmbiguousEnd $ + ElmStructure.ifElse "if" "then" "else" + (formatCommentedExpression elmVersion importInfo cond) + (formatCommented_ True $ syntaxParens SyntaxSeparated . formatExpression elmVersion importInfo <$> body) + (formatElseIf <$> elseifs) + (formatCommented_ True $ syntaxParens SyntaxSeparated . formatExpression elmVersion importInfo <$> C (elsComments, []) els) + + Let [] _ _ -> + pleaseReport "UNEXPECTED LET EXPRESSION" "No declarations" - Let defs bodyComments expr -> + Let (def1:defs) bodyComments expr -> let - spacer :: AST typeRef ctorRef varRef (I.Fix Identity (AST typeRef ctorRef varRef)) 'LetDeclarationNK -> AST typeRef ctorRef varRef getType 'LetDeclarationNK -> [Box] + spacer :: AST p (I.Fix (AST p)) 'LetDeclarationNK -> letDecl -> Int spacer first _ = case first of - LetCommonDeclaration (I.Fix (Identity (Definition _ _ _ _))) -> - [ blankLine ] - _ -> - [] + LetCommonDeclaration (I.Fix (Definition _ _ _ _)) -> 1 + _ -> 0 formatDefinition' def = case def of - LetCommonDeclaration (I.Fix (Identity (Definition name args comments expr'))) -> + LetCommonDeclaration (I.Fix (Definition name args comments expr')) -> formatDefinition elmVersion importInfo name args comments expr' - LetCommonDeclaration (I.Fix (Identity (TypeAnnotation name typ))) -> + LetCommonDeclaration (I.Fix (TypeAnnotation name typ)) -> formatTypeAnnotation elmVersion name typ LetComment comment -> formatComment comment in - (,) 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 + FormattedExpression AmbiguousEnd $ -- TODO: not tested + ElmStructure.letIn "let" "in" + (stackWithSpacing + (spacer . I.unFix) + (formatDefinition' . I.unFix) + def1 defs + ) + (ElmStructure.stack1 $ NonEmpty.fromList $ + fmap formatComment bodyComments ++ [syntaxParens SyntaxSeparated $ formatExpression elmVersion importInfo expr] - ] + ) Case (subject,multiline) clauses -> - let - opening = - case - ( multiline - , formatCommentedExpression elmVersion 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 elmVersion pat - |> syntaxParens SyntaxSeparated - |> negativeCasePatternWorkaround pat - , formatCommentedStack (fmap (syntaxParens SyntaxSeparated . formatPattern elmVersion) (C (prePat, postPat) pat)) - |> negativeCasePatternWorkaround pat - , formatPreCommentedStack $ fmap (syntaxParens SyntaxSeparated . formatExpression elmVersion 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 - (,) AmbiguousEnd $ -- TODO: not tested - opening - |> andThen - (clauses - |> fmap (clause . extract . I.unFix) - |> List.intersperse blankLine - |> map indent - ) + FormattedExpression AmbiguousEnd $ -- TODO: not tested + ElmStructure.case' "case" "of" multiline + (formatCommentedExpression elmVersion importInfo subject) + (formatCaseClause elmVersion importInfo . I.unFix <$> clauses) Tuple exprs multiline -> - (,) SyntaxSeparated $ - ElmStructure.group True "(" "," ")" multiline $ map (formatCommentedExpression elmVersion importInfo) exprs + FormattedExpression SyntaxSeparated $ + ElmStructure.group True "(" "," ")" multiline $ formatCommentedExpression elmVersion importInfo <$> exprs TupleFunction n -> - (,) SyntaxSeparated $ - line $ keyword $ "(" ++ List.replicate (n-1) ',' ++ ")" + FormattedExpression SyntaxSeparated $ + keyword $ "(" <> Text.replicate (n-1) "," <> ")" Access expr field -> - (,) SyntaxSeparated $ + FormattedExpression SyntaxSeparated $ formatExpression elmVersion importInfo expr |> syntaxParens SpaceSeparated -- TODO: does this need a different context than SpaceSeparated? - |> addSuffix (row $ [punc ".", formatLowercaseIdentifier elmVersion [] field]) + |> ElmStructure.suffix (punc "." <> Box.identifier (Text.pack $ (\(LowercaseIdentifier l) -> l) field)) AccessFunction (LowercaseIdentifier field) -> - (,) SyntaxSeparated $ - line $ identifier $ "." ++ formatVarName' elmVersion field + FormattedExpression SyntaxSeparated $ + ElmStructure.identifier $ "." <> Text.pack field Record base fields trailing multiline -> - (,) SyntaxSeparated $ + FormattedExpression SyntaxSeparated $ formatRecordLike - (fmap (line . formatLowercaseIdentifier elmVersion []) <$> base) - (fmap (formatPair "=" . mapPair (formatLowercaseIdentifier elmVersion []) (syntaxParens SyntaxSeparated . formatExpression elmVersion importInfo)) fields) + (fmap (formatLowercaseIdentifier []) <$> base) + (formatPair "=" . bimap (formatLowercaseIdentifier []) (syntaxParens SyntaxSeparated . formatExpression elmVersion importInfo) <$> fields) trailing multiline Parens expr -> @@ -1573,94 +1193,136 @@ formatExpression elmVersion importInfo aexpr = formatExpression elmVersion importInfo expr' _ -> - (,) SyntaxSeparated $ + FormattedExpression SyntaxSeparated $ formatCommentedExpression elmVersion importInfo expr |> parens - Unit comments -> - (,) SyntaxSeparated $ + FormattedExpression SyntaxSeparated $ formatUnit '(' ')' comments GLShader src -> - (,) SyntaxSeparated $ - line $ row - [ punc "[glsl|" - , literal src - , punc "|]" - ] + FormattedExpression SyntaxSeparated $ + ElmStructure.literal $ "[glsl|" <> Text.pack src <> "|]" + +formatCaseClause :: ElmVersion -> ImportInfo [UppercaseIdentifier] -> ASTNS [UppercaseIdentifier] (I.Fix (ASTNS [UppercaseIdentifier])) 'CaseBranchNK -> Elm +formatCaseClause elmVersion importInfo (CaseBranch prePat postPat preExpr pat expr) = + let + (pat', forceArrowNewline) = + case (prePat, postPat) of + ([], []) -> + ( negativeCasePatternWorkaround pat $ + syntaxParens SyntaxSeparated $ + formatAst elmVersion importInfo pat + , False + ) + + ((prePat1:prePats), []) -> + ( ElmStructure.stack1 $ NonEmpty.fromList + [ ElmStructure.stack1 $ formatComment <$> prePat1:|prePats + , negativeCasePatternWorkaround pat $ + syntaxParens SyntaxSeparated $ + formatAst elmVersion importInfo pat + ] + , False + ) + + (prePat', postPat') -> + ( negativeCasePatternWorkaround pat $ + formatCommentedStack (syntaxParens SyntaxSeparated . formatAst elmVersion importInfo <$> C (prePat', postPat') pat) + , True + ) + in + ElmStructure.caseBranch "->" forceArrowNewline + pat' + (formatPreCommentedStack $ syntaxParens SyntaxSeparated . formatExpression elmVersion importInfo <$> C preExpr expr) formatCommentedExpression :: ElmVersion -> ImportInfo [UppercaseIdentifier] - -> C2 before after (ASTNS Identity [UppercaseIdentifier] 'ExpressionNK) - -> Box + -> C2 before after (I.Fix (ASTNS [UppercaseIdentifier]) 'ExpressionNK) + -> Elm formatCommentedExpression elmVersion importInfo (C (pre, post) e) = let commented' = - case extract $ I.unFix e of + case I.unFix e of Parens (C (pre'', post'') e'') -> C (pre ++ pre'', post'' ++ post) e'' _ -> C (pre, post) e in - formatCommented $ fmap (syntaxParens SyntaxSeparated . formatExpression elmVersion importInfo) commented' - - -formatPreCommentedExpression :: - Coapplicative annf => - ElmVersion -> ImportInfo [UppercaseIdentifier] -> SyntaxContext - -> C1 before (ASTNS annf [UppercaseIdentifier] 'ExpressionNK) - -> Box -formatPreCommentedExpression elmVersion importInfo context (C pre e) = - let - (pre', e') = - case extract $ I.unFix e of - Parens (C (pre'', []) e'') -> - (pre ++ pre'', e'') - _ -> (pre, e) - in - formatCommented' pre' (syntaxParens context $ formatExpression elmVersion importInfo $ I.convert (Identity . extract) e') + formatCommented $ syntaxParens SyntaxSeparated . formatExpression elmVersion importInfo <$> commented' formatRecordLike :: - Maybe (C2 before after Box) -> Sequence Box -> Comments -> ForceMultiline - -> Box + Maybe (C2 before after Elm) -> Sequence Elm -> Comments -> ForceMultiline + -> Elm 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 -> ForceMultiline -> Comments -> Sequence Box -> Box -formatSequence left delim right (ForceMultiline multiline) trailing (Sequence (first:rest)) = + case base' of + Just base -> + case sequenceToSetionedGroups fields trailing of + Nothing -> + ElmStructure.spaceSepOrStack + (ElmStructure.spaceSepOrPrefix + (keyword "{") + (ElmStructure.spaceSepOrIndented (formatCommented base) [keyword "|"]) + ) + [keyword "}"] + + Just (firstGroup, moreGroups, extraFooter) -> + ElmStructure.extensionGroup "{" "|" "," "}" + ((\(ForceMultiline b) -> b) multiline) + (formatCommented base) + firstGroup moreGroups extraFooter + + Nothing-> + formatSequenceAsGroup '{' ',' '}' + multiline + trailing + fields + + +sequenceToSetionedGroups :: Sequence Elm -> Comments -> Maybe (NonEmpty Elm, [(Elm, NonEmpty Elm)], Maybe Elm) +sequenceToSetionedGroups items trailing = let - formatItem delim_ (C (pre, post, eol) item) = - maybe id (stack' . stack' blankLine) (formatComments pre) $ - prefix (row [ punc [delim_], space ]) $ - formatC2Eol $ C (post, [], eol) item + formatFirst (C (pre, post, eol) item) = + formatC2Eol $ C (pre ++ post, [], eol) item + + formatItem (C (pre, post, eol) item) = + case + ( formatComments pre + , formatC2Eol $ C (post, [], eol) item + ) + of + (Nothing, item') -> Right item' + (Just pre, item') -> Left (pre, item') in - ElmStructure.forceableSpaceSepOrStack multiline - (ElmStructure.forceableRowOrStack multiline - (formatItem left first) - (map (formatItem delim) rest) + case toCommentedList items of + [] -> + Nothing + + first:rest -> + let + (section1,sections) = + Data.Either.Extra.delimit $ formatItem <$> rest + in + Just + ( formatFirst first :| section1 + , (\((a,b), c) -> (a, b:|c)) <$> sections + , formatComments trailing ) - (maybe [] (flip (:) [] . stack' blankLine) (formatComments trailing) ++ Maybe.maybeToList (fmap (line . punc . flip (:) []) right)) -formatSequence left _ (Just right) _ trailing (Sequence []) = - formatUnit left right trailing -formatSequence left _ Nothing _ trailing (Sequence []) = - formatUnit left ' ' trailing + + +formatSequenceAsGroup :: Char -> Char -> Char -> ForceMultiline -> Comments -> Sequence Elm -> Elm +formatSequenceAsGroup left delim right (ForceMultiline multiline) trailing items = + case sequenceToSetionedGroups items trailing of + Nothing -> + formatUnit left right trailing + + Just (firstGroup, moreGroups, extraFooter) -> + ElmStructure.sectionedGroup True + (Text.singleton left) (Text.singleton delim) (Text.singleton right) + multiline + firstGroup moreGroups extraFooter mapIsLast :: (Bool -> a -> b) -> [a] -> [b] @@ -1670,15 +1332,14 @@ mapIsLast f (next:rest) = f False next : mapIsLast f rest formatBinops :: - ElmVersion - -> ImportInfo [UppercaseIdentifier] - -> ASTNS Identity [UppercaseIdentifier] 'ExpressionNK - -> [BinopsClause (Ref [UppercaseIdentifier]) (ASTNS Identity [UppercaseIdentifier] 'ExpressionNK)] + FormatResult 'ExpressionNK + -> [BinopsClause (I.Fix (AST (VariableNamespace [UppercaseIdentifier])) 'VarRefNK) (FormatResult 'ExpressionNK)] -> Bool - -> Box -formatBinops elmVersion importInfo left ops multiline = + -> Elm +formatBinops left ops multiline = let - formatPair_ isLast (BinopsClause po o pe e) = + formatPair_ :: Bool -> BinopsClause (I.Fix (AST (VariableNamespace [UppercaseIdentifier])) 'VarRefNK) (FormatResult 'ExpressionNK) -> (Bool, Comments, Elm, Elm) + formatPair_ isLast (BinopsClause po (I.Fix (VarRef_ o)) pe e) = let isLeftPipe = o == OpRef (SymbolIdentifier "<|") @@ -1690,104 +1351,32 @@ formatBinops elmVersion importInfo left ops multiline = in ( isLeftPipe , po - , (line . formatInfixVar elmVersion) o - , formatCommented' pe $ syntaxParens formatContext $ formatExpression elmVersion importInfo e + , formatInfixVar o + , formatCommented' pe $ syntaxParens formatContext e ) in formatBinary multiline - (syntaxParens InfixSeparated $ formatExpression elmVersion importInfo left) + (syntaxParens InfixSeparated left) (mapIsLast formatPair_ ops) -formatRange_0_17 :: - ElmVersion -> ImportInfo [UppercaseIdentifier] - -> C2 before after (ASTNS Identity [UppercaseIdentifier] 'ExpressionNK) - -> C2 before after (ASTNS Identity [UppercaseIdentifier] 'ExpressionNK) - -> Bool - -> Box -formatRange_0_17 elmVersion importInfo left right multiline = - case - ( multiline - , formatCommentedExpression elmVersion importInfo left - , formatCommentedExpression elmVersion importInfo right - ) - of - (False, SingleLine left', SingleLine right') -> - line $ row - [ punc "[" - , left' - , punc ".." - , right' - , punc "]" - ] - (_, left', right') -> - stack1 - [ line $ punc "[" - , indent left' - , line $ punc ".." - , indent right' - , line $ punc "]" - ] - -nowhere :: A.Position -nowhere = - A.Position 0 0 - - -noRegion :: a -> A.Located a -noRegion = - A.at nowhere nowhere - -formatRange_0_18 :: - Coapplicative annf => - ElmVersion -> ImportInfo [UppercaseIdentifier] - -> C2 before after (ASTNS annf [UppercaseIdentifier] 'ExpressionNK) - -> C2 before after (ASTNS annf [UppercaseIdentifier] 'ExpressionNK) - -> (SyntaxContext, Box) -formatRange_0_18 elmVersion 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 elmVersion 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 elmVersion importInfo - - -formatUnit :: Char -> Char -> Comments -> Box +formatUnit :: Char -> Char -> Comments -> Elm formatUnit left right comments = case (left, comments) of (_, []) -> - line $ punc [left, right] + keyword $ Text.pack [left, right] ('{', (LineComment _):_) -> - surround left right $ prefix space $ stack1 $ map formatComment comments - - _ -> - surround left right $ - case allSingles $ map formatComment comments of - Right comments' -> - line $ row $ List.intersperse space comments' + ElmStructure.groupOfOne "{ " (Text.singleton right) $ + ElmStructure.stack1 $ NonEmpty.fromList $ formatComment <$> comments - Left comments' -> - stack1 comments' + (_, first:rest) -> + ElmStructure.groupOfOne (Text.singleton left) (Text.singleton right) $ + ElmStructure.spaceSepOrStack (formatComment first) (formatComment <$> rest) -formatComments :: Comments -> Maybe Box +formatComments :: Comments -> Maybe Elm formatComments comments = case fmap formatComment comments of [] -> @@ -1797,120 +1386,98 @@ formatComments comments = Just $ ElmStructure.spaceSepOrStack first rest -formatCommented_ :: Bool -> C2 before after Box -> Box +formatCommented_ :: Bool -> C2 before after Elm -> Elm formatCommented_ forceMultiline (C (pre, post) inner) = - ElmStructure.forceableSpaceSepOrStack1 forceMultiline $ - concat - [ Maybe.maybeToList $ formatComments pre - , [inner] - , Maybe.maybeToList $ formatComments post - ] + ElmStructure.forceableSpaceSepOrStack1 forceMultiline $ NonEmpty.fromList $ concat + [ maybeToList $ formatComments pre + , [inner] + , maybeToList $ formatComments post + ] -formatCommented :: C2 before after Box -> Box +formatCommented :: C2 before after Elm -> Elm formatCommented = - formatCommented_ False + formatCommented_ False -formatPreCommented :: C1 before Box -> Box +formatPreCommented :: C1 before Elm -> Elm formatPreCommented (C pre inner) = - formatCommented' pre inner + formatCommented (C (pre, []) inner) -formatCommented' :: Comments -> Box -> Box +formatCommented' :: Comments -> Elm -> Elm formatCommented' pre inner = formatCommented (C (pre, []) inner) -formatTailCommented :: C1 after Box -> Box +formatTailCommented :: C1 after Elm -> Elm formatTailCommented (C post inner) = - formatCommented (C ([], post) inner) + formatCommented (C ([], post) inner) -formatC2Eol :: C2Eol before after Box -> Box +formatC2Eol :: C2Eol before after Elm -> Elm formatC2Eol (C (pre, post, eol) a) = formatCommented $ C (pre, post) $ formatEolCommented $ C eol a -formatEolCommented :: C0Eol Box -> Box -formatEolCommented (C post inner) = - case (post, inner) of - (Nothing, box) -> box - (Just eol, SingleLine result) -> - mustBreak $ row [ result, space, punc "--", literal eol ] - (Just eol, box) -> - stack1 [ box, formatComment $ LineComment eol ] +formatEolCommented :: C0Eol Elm -> Elm +formatEolCommented (C Nothing inner) = inner +formatEolCommented (C (Just eol) inner) = + ElmStructure.spaceSepMustBreak inner (formatComment $ LineComment eol) -formatCommentedStack :: C2 before after Box -> Box +formatCommentedStack :: C2 before after Elm -> Elm formatCommentedStack (C (pre, post) inner) = - stack1 $ - map formatComment pre - ++ [ inner ] - ++ map formatComment post + ElmStructure.stack1 $ NonEmpty.fromList $ + fmap formatComment pre + ++ [ inner ] + ++ fmap formatComment post -formatPreCommentedStack :: C1 before Box -> Box +formatPreCommentedStack :: C1 before Elm -> Elm formatPreCommentedStack (C pre inner) = - formatCommentedStack (C (pre, []) inner) + formatCommentedStack (C (pre, []) inner) -formatKeywordCommented :: String -> C2 beforeKeyword afterKeyword Box -> Box +formatKeywordCommented :: String -> C2 beforeKeyword afterKeyword Elm -> Elm formatKeywordCommented word (C (pre, post) value) = - ElmStructure.spaceSepOrIndented - (formatCommented $ fmap (line . keyword) (C (pre, post) word)) - [ value ] + ElmStructure.spaceSepOrIndented + (formatCommented $ keyword . Text.pack <$> C (pre, post) word) + [ value ] -formatOpenCommentedList :: OpenCommentedList Box -> [Box] +formatOpenCommentedList :: OpenCommentedList Elm -> [Elm] formatOpenCommentedList (OpenCommentedList rest (C (preLst, eol) lst)) = fmap formatC2Eol rest ++ [formatC2Eol $ C (preLst, [], eol) lst] -formatComment :: Comment -> Box +formatComment :: Comment -> Elm formatComment comment = case comment of BlockComment c -> - case c of - [] -> - line $ punc "{- -}" - [l] -> - line $ row - [ punc "{-" - , space - , literal l - , space - , punc "-}" - ] - ls -> - stack1 - [ prefix - (row [ punc "{-", space ]) - (stack1 $ map (line . literal) ls) - , line $ punc "-}" - ] + ElmStructure.commentBlock "{-" "-}" (Text.pack <$> c) LineComment c -> - mustBreak $ row [ punc "--", literal c ] + ElmStructure.mustBreakComment ("--" <> Text.pack c) CommentTrickOpener -> - mustBreak $ punc "{--}" + ElmStructure.mustBreakComment "{--}" CommentTrickCloser -> - mustBreak $ punc "--}" + ElmStructure.mustBreakComment "--}" CommentTrickBlock c -> - mustBreak $ row [ punc "{--", literal c, punc "-}" ] + ElmStructure.mustBreakComment ("{--" <> Text.pack c <> "-}") -formatLiteral :: ElmVersion -> LiteralValue -> Box +formatLiteral :: ElmVersion -> LiteralValue -> Elm formatLiteral elmVersion lit = case lit of IntNum i DecimalInt -> - line $ literal $ show i + ElmStructure.literal $ Text.pack $ show i IntNum i HexadecimalInt -> - line $ literal $ + ElmStructure.literal $ Text.pack $ if i < -0xFFFFFFFF then printf "-0x%016X" (-i) else if i < -0xFFFF then @@ -1928,15 +1495,15 @@ formatLiteral elmVersion lit = else printf "0x%016X" i FloatNum f DecimalFloat -> - line $ literal $ printf "%f" f + ElmStructure.literal $ Text.pack $ printf "%f" f FloatNum f ExponentFloat -> - line $ literal $ printf "%e" f + ElmStructure.literal $ Text.pack $ printf "%e" f Chr c -> formatString elmVersion SChar [c] Str s multi -> formatString elmVersion (SString multi) s Boolean b -> - line $ literal $ show b + ElmStructure.literal $ Text.pack $ show b data StringStyle @@ -1945,7 +1512,7 @@ data StringStyle deriving (Eq) -formatString :: ElmVersion -> StringStyle -> String -> Box +formatString :: ElmVersion -> StringStyle -> String -> Elm formatString elmVersion style s = case style of SChar -> @@ -1956,11 +1523,11 @@ formatString elmVersion style s = stringBox "\"\"\"" escapeMultiQuote where stringBox quotes escaper = - line $ row - [ punc quotes - , literal $ escaper $ concatMap fix s - , punc quotes - ] + ElmStructure.literal $ mconcat + [ quotes + , Text.pack $ escaper $ concatMap fix s + , quotes + ] fix c = if (style == SString TripleQuotedString) && c == '\n' then @@ -1989,7 +1556,7 @@ formatString elmVersion style s = hex char = case ElmVersion.style_0_19_stringEscape elmVersion of True -> - "\\u{" ++ (printf "%04X" $ Char.ord char) ++ "}" + "\\u{" ++ printf "%04X" (Char.ord char) ++ "}" False -> "\\x" ++ (printf fmt $ Char.ord char) where @@ -2033,7 +1600,7 @@ data TypeParensInner | ForTypeConstruction -typeParens :: TypeParensRequired -> (TypeParensInner, Box) -> Box +typeParens :: TypeParensRequired -> (TypeParensInner, Elm) -> Elm typeParens outer (inner, box) = if typeParensNeeded outer inner then parens box else box @@ -2047,27 +1614,23 @@ typeParensNeeded outer = \case commaSpace :: Line commaSpace = - row - [ punc "," - , space - ] + punc "," <> space -formatTypeConstructor :: ElmVersion -> TypeConstructor ([UppercaseIdentifier], UppercaseIdentifier) -> Box -formatTypeConstructor elmVersion ctor = +formatTypeConstructor :: TypeConstructor (I.Fix (ASTNS [UppercaseIdentifier]) 'TypeRefNK) -> Elm +formatTypeConstructor ctor = case ctor of - NamedConstructor (namespace, name) -> - line $ formatQualifiedUppercaseIdentifier elmVersion (namespace ++ [name]) + NamedConstructor (I.Fix (TypeRef_ (namespace, name))) -> + formatUppercaseIdentifier namespace name TupleConstructor n -> - line $ keyword $ "(" ++ List.replicate (n-1) ',' ++ ")" + keyword $ "(" <> Text.replicate (n-1) "," <> ")" formatType :: - Coapplicative annf => - ElmVersion -> ASTNS annf [UppercaseIdentifier] 'TypeNK -> (TypeParensInner, Box) + ElmVersion -> I.Fix (ASTNS [UppercaseIdentifier]) 'TypeNK -> (TypeParensInner, Elm) formatType elmVersion atype = - case extract $ I.unFix atype of + case I.unFix atype of UnitType comments -> (,) NotNeeded $ formatUnit '(' ')' comments @@ -2075,17 +1638,15 @@ formatType elmVersion atype = 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 elmVersion) - (C (postOp, [], eol) term) - ) - ] + ElmStructure.forceableSpaceSepOrStack1 False + $ NonEmpty.fromList $ catMaybes + [ formatComments preOp + , Just $ ElmStructure.prefixOrIndented + (keyword "->") + (formatC2Eol $ + (fmap $ typeParens ForLambda . formatType elmVersion) + (C (postOp, [], eol) term) + ) ] in (,) ForFunctionType $ @@ -2096,115 +1657,100 @@ formatType elmVersion atype = TypeVariable var -> (,) NotNeeded $ - line $ identifier $ formatVarName elmVersion var + formatLowercaseIdentifier [] var + + TypeConstruction ctor [] _ -> + (,) NotNeeded $ + formatTypeConstructor ctor - TypeConstruction ctor args forceMultiline -> + TypeConstruction ctor (arg0:args) forceMultiline -> let join = case forceMultiline of ForceMultiline True -> FASplitFirst ForceMultiline False -> FAJoinFirst JoinAll in - (,) (if null args then NotNeeded else ForTypeConstruction) $ + (,) ForTypeConstruction $ ElmStructure.application join - (formatTypeConstructor elmVersion ctor) - (fmap (formatPreCommented . fmap (typeParens ForCtor . formatType elmVersion)) args) + (formatTypeConstructor ctor) + (formatPreCommented . fmap (typeParens ForCtor . formatType elmVersion) <$> arg0:|args) TypeParens type' -> (,) NotNeeded $ - parens $ formatCommented $ fmap (typeParens NotRequired . formatType elmVersion) type' + parens $ formatCommented $ typeParens NotRequired . formatType elmVersion <$> type' TupleType types (ForceMultiline forceMultiline) -> (,) NotNeeded $ - ElmStructure.group True "(" "," ")" forceMultiline (fmap (formatC2Eol . fmap (typeParens NotRequired . formatType elmVersion)) types) + ElmStructure.group True "(" "," ")" forceMultiline (formatC2Eol . fmap (typeParens NotRequired . formatType elmVersion) <$> NonEmpty.toList types) RecordType base fields trailing multiline -> (,) NotNeeded $ formatRecordLike - (fmap (line . formatLowercaseIdentifier elmVersion []) <$> base) - (fmap (formatPair ":" . mapPair (formatLowercaseIdentifier elmVersion []) (typeParens NotRequired . formatType elmVersion)) fields) + (fmap (formatLowercaseIdentifier []) <$> base) + (formatPair ":" . bimap (formatLowercaseIdentifier []) (typeParens NotRequired . formatType elmVersion) <$> fields) trailing multiline -formatVar :: ElmVersion -> Ref [UppercaseIdentifier] -> Line -formatVar elmVersion var = +formatVar :: Ref [UppercaseIdentifier] -> Elm +formatVar var = case var of VarRef namespace name -> - formatLowercaseIdentifier elmVersion namespace name + formatLowercaseIdentifier namespace name TagRef namespace name -> - case namespace of - [] -> identifier $ formatVarName'' elmVersion name - _ -> - row - [ formatQualifiedUppercaseIdentifier elmVersion namespace - , punc "." - , identifier $ formatVarName'' elmVersion name - ] + formatUppercaseIdentifier namespace name OpRef name -> formatSymbolIdentifierInParens name -formatSymbolIdentifierInParens :: SymbolIdentifier -> Line +formatSymbolIdentifierAsInfix :: SymbolIdentifier -> Elm +formatSymbolIdentifierAsInfix (SymbolIdentifier name) = + ElmStructure.identifier $ Text.pack name + + +formatSymbolIdentifierInParens :: SymbolIdentifier -> Elm formatSymbolIdentifierInParens (SymbolIdentifier name) = - identifier $ "(" ++ name ++ ")" + ElmStructure.identifier $ "(" <> Text.pack name <> ")" -formatInfixVar :: ElmVersion -> Ref [UppercaseIdentifier] -> Line -formatInfixVar elmVersion var = +formatInfixVar :: Ref [UppercaseIdentifier] -> Elm +formatInfixVar var = case var of - VarRef _ _ -> - row [ punc "`" - , formatVar elmVersion var - , punc "`" - ] - TagRef _ _ -> - row [ punc "`" - , formatVar elmVersion var - , punc "`" - ] - OpRef (SymbolIdentifier name) -> - identifier name - - -formatLowercaseIdentifier :: ElmVersion -> [UppercaseIdentifier] -> LowercaseIdentifier -> Line -formatLowercaseIdentifier elmVersion namespace (LowercaseIdentifier name) = - case (elmVersion, namespace, name) of - (_, [], _) -> identifier $ formatVarName' elmVersion name - _ -> - row - [ formatQualifiedUppercaseIdentifier elmVersion namespace - , punc "." - , identifier $ formatVarName' elmVersion name - ] + VarRef namespace name -> + ElmStructure.groupOfOne "`" "`" $ + formatLowercaseIdentifier namespace name + TagRef namespace name -> + ElmStructure.groupOfOne "`" "`" $ + formatUppercaseIdentifier namespace name -formatUppercaseIdentifier :: ElmVersion -> UppercaseIdentifier -> Line -formatUppercaseIdentifier elmVersion (UppercaseIdentifier name) = - identifier $ formatVarName' elmVersion name + OpRef op -> + formatSymbolIdentifierAsInfix op -formatQualifiedUppercaseIdentifier :: ElmVersion -> [UppercaseIdentifier] -> Line -formatQualifiedUppercaseIdentifier elmVersion names = - identifier $ List.intercalate "." $ - map (\(UppercaseIdentifier name) -> formatVarName' elmVersion name) names +formatQualifiedIdentifier :: [UppercaseIdentifier] -> Text -> Elm +formatQualifiedIdentifier namespace name = + let + namespace' = Text.pack . (\(UppercaseIdentifier n) -> n) <$> namespace + in + ElmStructure.identifier + (Text.intercalate "." (namespace' ++ [name])) -formatVarName :: ElmVersion -> LowercaseIdentifier -> String -formatVarName elmVersion (LowercaseIdentifier name) = - formatVarName' elmVersion name +formatLowercaseIdentifier :: [UppercaseIdentifier] -> LowercaseIdentifier -> Elm +formatLowercaseIdentifier namespace (LowercaseIdentifier name) = + formatQualifiedIdentifier namespace (Text.pack name) -formatVarName' :: ElmVersion -> String -> String -formatVarName' elmVersion name = - case elmVersion of - Elm_0_16 -> name - Elm_0_17 -> name - _ -> map (\x -> if x == '\'' then '_' else x) name +formatUppercaseIdentifier :: [UppercaseIdentifier] -> UppercaseIdentifier -> Elm +formatUppercaseIdentifier namespace (UppercaseIdentifier name) = + formatQualifiedIdentifier namespace (Text.pack name) -formatVarName'' :: ElmVersion -> UppercaseIdentifier -> String -formatVarName'' elmVersion (UppercaseIdentifier name) = - formatVarName' elmVersion name +formatUppercaseIdentifier' :: [UppercaseIdentifier] -> Elm +formatUppercaseIdentifier' [] = + pleaseReport "UPEXPECTED UPPERCASE IDENTIFIER" "no name" +formatUppercaseIdentifier' some = + formatUppercaseIdentifier (List.init some) (List.last some) diff --git a/elm-format-lib/src/ElmFormat/Render/ElmStructure.hs b/elm-format-lib/src/ElmFormat/Render/ElmStructure.hs index 50bd3c70c..72e043b1f 100644 --- a/elm-format-lib/src/ElmFormat/Render/ElmStructure.hs +++ b/elm-format-lib/src/ElmFormat/Render/ElmStructure.hs @@ -1,25 +1,680 @@ -{-# OPTIONS_GHC -Wall #-} module ElmFormat.Render.ElmStructure ( spaceSepOrStack, forceableSpaceSepOrStack, forceableSpaceSepOrStack1 , forceableRowOrStack , spaceSepOrIndented, forceableSpaceSepOrIndented, spaceSepOrPrefix, prefixOrIndented , equalsPair, definition - , application, group, group', extensionGroup, extensionGroup' ) + , application, group, group', extensionGroup, render,keyword, Elm,groupOfOne,parens,module',identifier,docComment,import',stackWithVariableSpacing,stack1,commentBlock,mustBreakComment,literal,case',caseBranch,unionListing,stackIndent,letIn,ifElse,spaceSepMustBreak,lambda,sectionedGroup,suffix,range,unary) where import Elm.Utils ((|>)) import Box + ( Box(..), + space, + indent, + isLine, + allSingles, + prefix, + lineLength, + isSingle, + isMustBreak, blankLine ) import AST.V0_16 (FunctionApplicationMultiline(..), Multiline(..)) +import Control.Monad (mzero, MonadPlus) +import Data.Fix (Fix (Fix)) + +import qualified Box import qualified Data.List as List +import Data.Maybe (maybeToList, catMaybes) +import Data.List (intersperse) +import Data.Text (Text) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Semigroup (sconcat) +import qualified Data.List.NonEmpty as NonEmpty + + +data ElmF a + = Keyword Text + | Literal Text + | Identifier Text + | DocComment Text Text [Text] + | CommentBlock Text [Text] Text + | MustBreakComment Text + | Suffix a Box.Line + | WrapStack a a [a] + | WrapStackNoSpaces a a [a] + | WrapIndent a a [a] + | JoinMustBreak a a + | Stack a (Int, a) [(Int, a)] + | StackIndent a a [a] + | PrefixOrIndent a a + | EqualsPair Bool a Text a + | FunctionApplication FunctionApplicationMultiline a (NonEmpty a) + | Case Text Text Bool a [a] + | CaseClause Bool a Text a + | LetIn Text a Text a + | IfElse Text a Text a [(Maybe a, a, a)] Text a + | Lambda Text Text Bool a (Maybe a) a + | SectionedGroup Bool Text Text Text Bool (NonEmpty a) [(a, NonEmpty a)] (Maybe a) + | GroupOfOne Text a Text + | ExtensionGroup Text Text Text Text Bool a (NonEmpty a) [(a, NonEmpty a)] (Maybe a) + | Range Text Text Text a a + | OperatorPrefix Bool a a + | Module [a] (Maybe a, Maybe a, (Maybe a, [a])) Int (Maybe a) + | Import a (Maybe a) (Maybe a) + | UnionListing a Bool (Maybe a) + deriving (Functor) + +type Elm = Fix ElmF + + +render :: ElmF Box -> Box +render = \case + Keyword k -> + Box.line $ Box.keyword k + + Literal l -> + Box.line $ Box.literal l + + Identifier name -> + Box.line $ Box.identifier name + + CommentBlock left inner right -> + case inner of + [] -> + Box.line $ Box.comment (left <> " " <> right) + + [single] -> + Box.line $ Box.comment (left <> " " <> single <> " " <> right) + + (first:rest) -> + Box.stack' + (Box.prefix + (Box.comment (left <> " ")) + (Box.stack + (Box.line $ Box.comment first) + (Box.line . Box.comment <$> rest) + ) + ) + (Box.line $ Box.comment right) + + MustBreakComment line -> + Box.mustBreak $ Box.comment line + + Suffix a suf -> + Box.addSuffix suf a + + DocComment left right lines' -> + case lines' of + [] -> + Box.line $ Box.punc left <> space <> Box.punc right + + [first] -> + Box.stack1 + [ Box.line $ Box.punc left <> space <> Box.literal first + , Box.line $ Box.punc right + ] + + (first:rest) -> + Box.line (Box.punc left <> space <> Box.literal first) + |> Box.andThen (map (Box.line . Box.literal) rest) + |> Box.andThen [ Box.line $ Box.punc right ] + + WrapStack a b rest -> + firstOf + [ Box.line . sconcat . NonEmpty.intersperse space + <$> traverse isSingle (a:|b:rest) + ] + $ render (stack0 a b rest) + + WrapStackNoSpaces a b rest -> + firstOf + [ Box.line . sconcat + <$> traverse isSingle (a:|b:rest) + ] + $ render (stack0 a b rest) + + WrapIndent a b rest -> + firstOf + [ Box.line . sconcat . NonEmpty.intersperse space + <$> traverse isSingle (a:|b:rest) + ] + $ render (StackIndent a b rest) + + JoinMustBreak inner eol -> + Box.joinMustBreak inner eol + + Stack a b rest -> + Box.stack a (mconcat (pair <$> b:rest)) + where + pair (n, x) = + List.replicate n Box.blankLine ++ [x] + + StackIndent a b rest -> + Box.stack a (indent <$> (b:rest)) + + PrefixOrIndent a b -> + Box.prefixOrIndent a b + + EqualsPair forceMultiline left symbol right -> + firstOf + [ unless forceMultiline $ + Box.line . sconcat . NonEmpty.intersperse space . NonEmpty.fromList <$> sequenceA + [ isSingle left + , pure $ Box.punc symbol + , isSingle right + ] + + , Box.mustBreak . sconcat . NonEmpty.intersperse space . NonEmpty.fromList <$> sequenceA + [ isSingle left + , pure $ Box.punc symbol + , isMustBreak right + ] + + , do + left' <- isSingle left + pure $ Box.stack' + (Box.line $ left' <> space <> Box.punc symbol) + (indent right) + ] + $ Box.stack1 + [ left + , indent $ Box.line $ Box.punc symbol + , indent right + ] + + FunctionApplication forceMultiline first (arg0:|rest) -> + case + ( forceMultiline + , Box.allSingles (first :| [arg0]) + , allSingles (first : arg0 : rest) + ) + of + ( FAJoinFirst JoinAll, _, Right all' ) -> + Box.line $ sconcat $ NonEmpty.intersperse space $ NonEmpty.fromList all' + + ( FAJoinFirst _, Right firstTwo, _) -> + Box.stack + (Box.line $ sconcat $ NonEmpty.intersperse space firstTwo) + (indent <$> rest) + + _ -> + Box.stack first (indent <$> (arg0:rest)) + + Case caseWord ofWord forceMultilineSubject subject clauses -> + let + opening = + case + ( forceMultilineSubject + , isLine subject + ) + of + (False, Right subject'') -> + Box.line $ + Box.keyword caseWord + <> space + <> subject'' + <> space + <> Box.keyword ofWord + _ -> + Box.stack + (Box.line $ Box.keyword caseWord) + [ Box.indent subject + , Box.line $ Box.keyword ofWord + ] + in + Box.stack + opening + (indent <$> List.intersperse blankLine clauses) + + CaseClause forceArrowNewline pattern arrow body -> + case (forceArrowNewline, isSingle pattern) of + (False, Just pat') -> + Box.stack' + (Box.line $ pat' <> space <> Box.keyword arrow) + (indent body) + + (False, Nothing) -> + Box.stack' + (Box.addSuffix (space <> Box.keyword arrow) pattern) + (Box.indent body) + + (True, _) -> + Box.stack + pattern + [ Box.line $ Box.keyword arrow + , Box.indent body + ] + + LetIn letWord defs inWord body -> + Box.stack1 + [ Box.line $ Box.keyword letWord + , Box.indent defs + , Box.line $ Box.keyword inWord + , body + ] + + IfElse ifWord condition thenWord ifBody elseIfs elseWord elseBody -> + let + opening key cond = + render $ WrapStack + (render $ WrapIndent key cond []) + (Box.line $ Box.keyword thenWord) + [] + + formatElseIf (ifComments, cond, body) = + let + if' = + case ifComments of + Nothing-> Box.line $ Box.keyword ifWord + Just c -> + render $ WrapStack c (Box.line $ Box.keyword ifWord) [] + + key = + render $ WrapStack + (Box.line $ Box.keyword elseWord) + if' + [] + in + Box.stack + blankLine + [ opening key cond + , indent body + ] + in + Box.stack' + (opening (Box.line $ Box.keyword ifWord) condition) + (indent ifBody) + |> Box.andThen (formatElseIf <$> elseIfs) + |> Box.andThen + [ blankLine + , Box.line $ Box.keyword elseWord + , indent elseBody + ] + + Lambda start arrow forceMultiline args bodyComments body -> + case + ( forceMultiline + , isLine args + , bodyComments + , isLine body + ) + of + (False, Right args', Nothing, Right expr'') -> + Box.line $ sconcat $ NonEmpty.fromList + [ Box.punc start + , args' + , space + , Box.punc arrow + , space + , expr'' + ] + + (_, Right args', _, _) -> + Box.stack' + (Box.line $ + Box.punc start + <> args' + <> space + <> Box.punc arrow + ) + (indent $ Box.stack1 $ catMaybes + [ bodyComments + , Just body + ] + ) + + (_, Left args', _, _) -> + Box.stack + (prefix (Box.punc start) args') + [ Box.line $ Box.punc arrow + , indent $ Box.stack1 $ catMaybes + [ bodyComments + , Just body + ] + ] + + SectionedGroup innerSpaces left sep right forceMultiline section1 moreSections extraFooter -> + let + forceMultiline' = + forceMultiline || not (null moreSections) + + forceWrap wrap = + if forceMultiline' then stack0 else wrap + + final = + case extraFooter of + Nothing -> Box.line $ Box.punc right + Just footer -> + render $ stack0 + blankLine + footer + [ Box.line $ Box.punc right ] + + attempt innerSpaces' = + render $ forceWrap (if innerSpaces' then WrapStack else WrapStackNoSpaces) + (renderSections innerSpaces' forceMultiline' left sep section1 moreSections) + final + [] + + withInnerSpaces = + attempt True + in + case (innerSpaces, isLine withInnerSpaces) of + (False, Right _) -> attempt False + _ -> withInnerSpaces + + GroupOfOne left inner right -> + let + left' = Box.punc left + right' = Box.punc right + in + case isLine inner of + Right inner' -> + Box.line $ left' <> inner' <> right' + + Left inner' -> + Box.stack' + (prefix left' inner') + (Box.line right') + + ExtensionGroup left delim sep right forceMultiline base section1 moreSections extraFooter -> + let + extraFooter' = + case extraFooter of + Nothing -> [] + Just f -> [ blankLine, f ] + in + render $ (if forceMultiline then stack0 else WrapStack) + (render $ (if forceMultiline then StackIndent else WrapIndent) + (render $ OperatorPrefix True (Box.line $ Box.punc left) base) + (renderSections True forceMultiline delim sep section1 moreSections) + extraFooter' + ) + (Box.line $ Box.punc right) + [] + + Range left dots right a b -> + case Box.allSingles2 a b of + Right (a', b') -> + Box.line $ + Box.punc left + <> a' + <> Box.punc dots + <> b' + <> Box.punc right + + Left (a', b') -> + Box.stack1 + [ Box.line $ Box.punc left + , indent a' + , Box.line $ Box.punc dots + , indent b' + , Box.line $ Box.punc right + ] + + OperatorPrefix innerSpaces op rest -> + let + withSpace o = + if innerSpaces + then o <> space + else o + in + case ( isLine op, isLine rest) of + ( Right op', Right rest' ) -> + Box.line $ withSpace op' <> rest' + + ( Right op', _ ) | lineLength op' < 4 -> + prefix (withSpace op') rest + + _ -> + Box.stack' op (indent rest) + + Module initialComments (maybeHeader, docs, (importComments, imports)) spaceBeforeBody body -> + let + initialComments' = + case initialComments of + [] -> [] + some -> some <> [ blankLine, blankLine ] + + imports' = + [ maybeToList importComments + , imports + ] + |> List.filter (not . List.null) + |> List.intersperse [blankLine] + |> concat + in + Box.stack1 $ concat + [ initialComments' + , List.intercalate [ blankLine ] $ concat + [ maybeToList $ return <$> maybeHeader + , maybeToList $ return <$> docs + , [imports' | not (null imports')] + ] + , List.replicate spaceBeforeBody blankLine + , maybeToList body + ] + + Import name as exposing -> + case + ( isLine name + , isLine <$> as + , isLine <$> exposing + ) + of + ( Right name', Just (Right as'), Just (Right exposing') ) -> + Box.line $ sconcat $ NonEmpty.fromList $ intersperse space + [ Box.keyword "import" + , name' + , as' + , exposing' + ] + + (Right name', Just (Right as'), Nothing) -> + Box.line $ sconcat $ NonEmpty.fromList $ intersperse space + [ Box.keyword "import" + , name' + , as' + ] + + (Right name', Nothing, Just (Right exposing')) -> + Box.line $ sconcat $ NonEmpty.fromList $ intersperse space + [ Box.keyword "import" + , name' + , exposing' + ] + + (Right name', Nothing, Nothing) -> + Box.line $ sconcat $ NonEmpty.fromList $ intersperse space + [ Box.keyword "import" + , name' + ] + + ( Right name', Just (Right as'), Just _ ) -> + Box.stack1 + [ Box.line $ sconcat $ NonEmpty.fromList $ intersperse space + [ Box.keyword "import" + , name' + , as' + ] + , maybe undefined indent exposing + ] + + ( Right name', Just _, Just _ ) -> + Box.stack1 + [ Box.line $ sconcat $ NonEmpty.fromList $ intersperse space + [ Box.keyword "import" + , name' + ] + , maybe undefined indent as + , maybe undefined indent exposing + ] + + ( Right name', Nothing, Just _ ) -> + Box.stack1 + [ Box.line $ sconcat $ NonEmpty.fromList $ intersperse space + [ Box.keyword "import" + , name' + ] + , maybe undefined indent exposing + ] + + ( _, Just _, Just _ ) -> + Box.stack1 + [ Box.line $ Box.keyword "import" + , indent name + , maybe undefined (indent . indent) as + , maybe undefined (indent . indent) exposing + ] + + ( _, Nothing, Just _ ) -> + Box.stack1 + [ Box.line $ Box.keyword "import" + , indent name + , maybe undefined (indent . indent) exposing + ] + + ( _, Just _, Nothing ) -> + Box.stack1 + [ Box.line $ Box.keyword "import" + , indent name + , maybe undefined (indent . indent) as + ] + + ( _, Nothing, Nothing ) -> + Box.stack' + (Box.line $ Box.keyword "import") + (indent name) + + UnionListing name nameHasComments listing -> + case + ( listing + , isSingle <$> listing + , isSingle name + , nameHasComments + ) + of + (_, Just (Just listing'), Just name', False) -> + Box.line $ name' <> listing' + + (Just listing', _, _, _) -> + render $ WrapIndent name listing' [] + + (Nothing, _, _, _) -> + name + + +firstOf :: [Maybe a] -> a -> a +firstOf [] = id +firstOf (Just a : _) = const a +firstOf (Nothing : rest) = firstOf rest + + +unless :: MonadPlus m => Bool -> m a -> m a +unless False = id +unless True = const mzero + + +stack0 :: a -> a -> [a] -> ElmF a +stack0 a b rest = + Stack a (0, b) ((,) 0 <$> rest) + + +renderSections :: Bool -> Bool -> Text -> Text -> NonEmpty Box -> [(Box, NonEmpty Box)] -> Box +renderSections innerSpaces forceMultiline left sep (first0':|firsts') moreSections' = + let + forceWrap wrap = + if forceMultiline + then stack0 + else wrap + + renderItem innerSpaces' punc item = + render $ OperatorPrefix + (innerSpaces' || punc == sep) + (Box.line $ Box.punc punc) + item + + + renderLabeledSection innerSpaces' (label, items) = + Box.stack + blankLine + [ label + , renderSections forceMultiline innerSpaces' sep sep items [] + ] + + joinItems a [] [] = a + joinItems a [] (b:rest) = + render $ forceWrap WrapStackNoSpaces a b rest + joinItems a (b:rest1) rest2 = + render $ forceWrap WrapStackNoSpaces a b (rest1 ++ rest2) + in + joinItems + (renderItem innerSpaces left first0') + (renderItem innerSpaces sep <$> firsts') + (renderLabeledSection innerSpaces <$> moreSections') + + +keyword :: Text -> Elm +keyword = Fix . Keyword + + +literal :: Text -> Elm +literal = Fix . Literal + + +identifier :: Text -> Elm +identifier = Fix . Identifier + + +parens :: Elm -> Elm +parens = groupOfOne "(" ")" + + +groupOfOne :: Text -> Text -> Elm -> Elm +groupOfOne left right inner = + Fix $ GroupOfOne left inner right + + +docComment :: Text -> Text -> [Text] -> Elm +docComment left right lines' = + Fix $ DocComment left right lines' + + +commentBlock :: Text -> Text -> [Text] -> Elm +commentBlock left right inner = + Fix $ CommentBlock left inner right + + +mustBreakComment :: Text -> Elm +mustBreakComment = Fix . MustBreakComment + + +suffix :: Box.Line -> Elm -> Elm +suffix suf a = + Fix $ Suffix a suf + + +module' :: [Elm] -> (Maybe Elm, Maybe Elm, (Maybe Elm, [Elm])) -> Int -> Maybe Elm -> Elm +module' initialComments header spaceBeforeBody body = + Fix $ Module initialComments header spaceBeforeBody body + + +import' :: Elm -> Maybe Elm -> Maybe Elm -> Elm +import' name as exposing = + Fix $ Import name as exposing + + +unionListing :: Elm -> Bool -> Maybe Elm -> Elm +unionListing name nameHasComments listing = + Fix $ UnionListing name nameHasComments listing {-| Same as `forceableSpaceSepOrStack False` -} -spaceSepOrStack :: Box -> [Box] -> Box -spaceSepOrStack = - forceableSpaceSepOrStack False +spaceSepOrStack :: Elm -> [Elm] -> Elm +spaceSepOrStack a [] = a +spaceSepOrStack a (b:rest) = Fix $ WrapStack a b rest {-| @@ -31,42 +686,36 @@ Formats as: rest0 rest1 -} -forceableSpaceSepOrStack :: Bool -> Box -> [Box] -> Box -forceableSpaceSepOrStack forceMultiline first rest = - case - ( forceMultiline, first, allSingles rest, rest ) - of - ( False, SingleLine first', Right rest', _ ) -> - line $ row $ List.intersperse space (first' : rest') +forceableSpaceSepOrStack :: Bool -> Elm -> [Elm] -> Elm +forceableSpaceSepOrStack _ a [] = a +forceableSpaceSepOrStack True a (b:rest) = Fix $ stack0 a b rest +forceableSpaceSepOrStack False a (b:rest) = Fix $ WrapStack a b rest - _ -> - stack1 (first : rest) +{-| Like `forceableSpaceSepOrStack`, but doesn't add spaces when +everything remains on one line. +-} +forceableRowOrStack :: Bool -> Elm -> [Elm] -> Elm +forceableRowOrStack _ a [] = a +forceableRowOrStack True a (b:rest) = Fix $ stack0 a b rest +forceableRowOrStack False a (b:rest) = Fix $ WrapStackNoSpaces a b rest -forceableRowOrStack :: Bool -> Box -> [Box] -> Box -forceableRowOrStack forceMultiline first rest = - case - ( forceMultiline, first, allSingles rest, rest ) - of - ( False, SingleLine first', Right rest', _ ) -> - line $ row (first' : rest') - +{-| Same as `forceableSpaceSepOrStack` +-} +forceableSpaceSepOrStack1 :: Bool -> NonEmpty Elm -> Elm +forceableSpaceSepOrStack1 forceMultiline (first:|rest) = + forceableSpaceSepOrStack forceMultiline first rest - _ -> - stack1 (first : rest) +stack1 :: NonEmpty Elm -> Elm +stack1 = forceableSpaceSepOrStack1 True -{-| Same as `forceableSpaceSepOrStack` --} -forceableSpaceSepOrStack1 :: Bool -> [Box] -> Box -forceableSpaceSepOrStack1 forceMultiline boxes = - case boxes of - (first:rest) -> - forceableSpaceSepOrStack forceMultiline first rest - _ -> - error "forceableSpaceSepOrStack1 with empty list" +stackWithVariableSpacing :: Elm -> [(Int, Elm)] -> Elm +stackWithVariableSpacing a [] = a +stackWithVariableSpacing a (b:rest) = + Fix $ Stack a b rest {-| @@ -79,23 +728,19 @@ Formats as: rest1 rest2 -} -spaceSepOrIndented :: Box -> [Box] -> Box -spaceSepOrIndented = - forceableSpaceSepOrIndented False +spaceSepOrIndented :: Elm -> [Elm] -> Elm +spaceSepOrIndented a [] = a +spaceSepOrIndented a (b:rest) = Fix $ WrapIndent a b rest -forceableSpaceSepOrIndented :: Bool -> Box -> [Box] -> Box -forceableSpaceSepOrIndented forceMultiline first rest = - case - ( forceMultiline, first, allSingles rest, rest ) - of - ( False, SingleLine first', Right rest', _ ) -> - line $ row $ List.intersperse space (first' : rest') +forceableSpaceSepOrIndented :: Bool -> Elm -> [Elm] -> Elm +forceableSpaceSepOrIndented _ a [] = a +forceableSpaceSepOrIndented True a (b:rest) = Fix $ StackIndent a b rest +forceableSpaceSepOrIndented False a (b:rest) = Fix $ WrapIndent a b rest - _ -> - stack1 - ( first : map indent rest) +stackIndent :: Elm -> [Elm] -> Elm +stackIndent = forceableSpaceSepOrIndented True {-| @@ -109,30 +754,19 @@ Formats as: opLong rest -} -spaceSepOrPrefix :: Box -> Box -> Box +spaceSepOrPrefix :: Elm -> Elm -> Elm spaceSepOrPrefix op rest = - case ( op, rest) of - ( SingleLine op', SingleLine rest' ) -> - line $ row [ op', space, rest' ] - - ( SingleLine op', _ ) | lineLength 0 op' < 4 -> - prefix (row [ op', space ]) rest + Fix $ OperatorPrefix True op rest - _ -> - stack1 [ op, indent rest ] +spaceSepMustBreak :: Elm -> Elm -> Elm +spaceSepMustBreak inner eol = + Fix $ JoinMustBreak inner eol -prefixOrIndented :: Box -> Box -> Box -prefixOrIndented a b = - case ( a, b ) of - ( SingleLine a', SingleLine b' ) -> - line $ row [ a', space, b' ] - ( SingleLine a', MustBreak b' ) -> - mustBreak $ row [ a', space, b' ] - - _ -> - stack1 [ a, indent b ] +prefixOrIndented :: Elm -> Elm -> Elm +prefixOrIndented pre body = + Fix $ PrefixOrIndent pre body {-| @@ -147,48 +781,20 @@ Formats as: = right -} -equalsPair :: String -> Bool -> Box -> Box -> Box +equalsPair :: Text -> Bool -> Elm -> Elm -> Elm equalsPair symbol forceMultiline left right = - case (forceMultiline, left, right) of - ( False, SingleLine left', SingleLine right' ) -> - line $ row - [ left' - , space - , punc symbol - , space - , right' - ] - - ( _, SingleLine left', MustBreak right' ) -> - mustBreak $ row - [ left' - , space - , punc symbol - , space - , right' - ] - - ( _, SingleLine left', right' ) -> - stack1 - [ line $ row [ left', space, punc symbol ] - , indent right' - ] - - ( _, left', right' ) -> - stack1 - [ left' - , indent $ line $ punc symbol - , indent right' - ] + Fix $ EqualsPair forceMultiline left symbol right {-| An equalsPair where the left side is an application -} -definition :: String -> Bool -> Box -> [Box] -> Box -> Box -definition symbol forceMultiline first rest = - equalsPair symbol forceMultiline - (application (FAJoinFirst JoinAll) first rest) +definition :: Text -> Bool -> Elm -> [Elm] -> Elm -> Elm +definition symbol forceMultiline first [] = + equalsPair symbol forceMultiline first +definition symbol forceMultiline first (arg0:args) = + equalsPair symbol forceMultiline + (application (FAJoinFirst JoinAll) first (arg0:|args)) {-| @@ -205,79 +811,146 @@ Formats as: rest1 rest2 -} -application :: FunctionApplicationMultiline -> Box -> [Box] -> Box -application forceMultiline first args = - case args of - [] -> - first - - arg0 : rest -> - case - ( forceMultiline - , first - , arg0 - , allSingles rest - ) - of - ( FAJoinFirst JoinAll, SingleLine first', SingleLine arg0', Right rest' ) -> - (first' : arg0' : rest' ) - |> List.intersperse space - |> row - |> line - - ( FAJoinFirst _, SingleLine first', SingleLine arg0', _) -> - stack1 - $ line ( row [ first', space, arg0' ]) - : map indent rest - - _ -> - stack1 - $ first : map indent (arg0 : rest) +application :: FunctionApplicationMultiline -> Elm -> NonEmpty Elm -> Elm +application forceMultiline f args = + Fix $ FunctionApplication forceMultiline f args + + +unary :: Elm -> Elm -> Elm +unary op a = + Fix $ OperatorPrefix False op a + + +{-| +Formats as: + + case subject of + clause0 + clause1 + + case + subject + of + clause0 + clause1 +-} +case' :: Text -> Text -> Bool -> Elm -> [Elm] -> Elm +case' caseWord ofWord forceMultilineSubect subject clauses = + Fix $ Case caseWord ofWord forceMultilineSubect subject clauses + + +{-| +Formats as: + + pattern -> + body + + pattern + -> + body +-} +caseBranch :: Text -> Bool -> Elm -> Elm -> Elm +caseBranch arrow forceArrowNewline pattern body = + Fix $ CaseClause forceArrowNewline pattern arrow body + + +{-| +Formats as: + + let + defs + in + body +-} +letIn :: Text -> Text -> Elm -> Elm -> Elm +letIn letWord inWord defs body = + Fix $ LetIn letWord defs inWord body + + +{-| +Formats as: + + if condition then + ifBody + else if condition1 then + elseIfBody1 + else + elseBody +-} +ifElse :: Text -> Text -> Text -> Elm -> Elm -> [(Maybe Elm, Elm, Elm)] -> Elm -> Elm +ifElse ifWord thenWord elseWord condition ifBody elseIfs elseBody = + Fix $ IfElse ifWord condition thenWord ifBody elseIfs elseWord elseBody + + +{-| +Formats as: + + \arg0 arg1 arg2 -> body + + \arg0 arg1 arg2 -> + body +-} +lambda :: Text -> Text -> Bool -> Elm -> Maybe Elm -> Elm -> Elm +lambda start arrow forceMultiline args bodyComments body = + Fix $ Lambda start arrow forceMultiline args bodyComments body + {-| `group True '<' ';' '>'` formats as: <> - < child0 > + < item0 > + + < item0; item1; item2 > + + < item0 + ; item1 + ; item2 + > +-} +group :: Bool -> Text -> Text -> Text -> Bool -> [Elm] -> Elm +group innerSpaces left sep right forceMultiline items = + group' innerSpaces left sep Nothing right forceMultiline items + + +{-| +Formats like `group` if there is no extraFooter, or as: - < child0; child1; child2 > + < item0 + ; item1 + ; item2 - < child0 - ; child1 - ; child2 + extraFooter > + -} -group :: Bool -> String -> String -> String -> Bool -> [Box] -> Box -group innerSpaces left sep right forceMultiline children = - group' innerSpaces left sep [] right forceMultiline children - - -group' :: Bool -> String -> String -> [Box] -> String -> Bool -> [Box] -> Box -group' innerSpaces left sep extraFooter right forceMultiline children = - case (forceMultiline, allSingles children, allSingles extraFooter) of - (_, Right [], Right efs) -> - line $ row $ concat [[punc left], efs, [punc right]] - - (False, Right ls, Right efs) -> - line $ row $ concat - [ if innerSpaces then [punc left, space] else [punc left] - , List.intersperse (row [punc sep, space]) (ls ++ efs) - , if innerSpaces then [space, punc right] else [punc right] - ] - - _ -> - case children of - [] -> - -- TODO: might lose extraFooter in this case, but can that ever happen? - line $ row [ punc left, punc right] - - (first:rest) -> - stack1 $ - prefix (row [punc left, space]) first - : map (prefix $ row [punc sep, space]) rest - ++ extraFooter - ++ [ line $ punc right ] +group' :: Bool -> Text -> Text -> Maybe Elm -> Text -> Bool -> [Elm] -> Elm +group' _ left _ Nothing right _ [] = + Fix $ Keyword (left <> right) +group' innerSpaces left _ (Just extraFooter) right _ [] = + groupOfOne left right extraFooter +group' innerSpaces left sep extraFooter right forceMultiline (first:rest) = + sectionedGroup innerSpaces left sep right forceMultiline (first:|rest) [] extraFooter + + +{-| +Formats like `group'` if there are no labelled sections, or as: + + < item0.0 + ; item0.1 + + label1 + ; item1.0 + ; item1.1 + + extraFooter + > + +-} +sectionedGroup :: Bool -> Text -> Text -> Text -> Bool -> NonEmpty Elm -> [(Elm, NonEmpty Elm)] -> Maybe Elm -> Elm +sectionedGroup innerSpaces left sep right forceMultiline section1 sections extraFooter = + Fix $ SectionedGroup innerSpaces left sep right forceMultiline section1 sections extraFooter {-| Formats as: @@ -292,57 +965,22 @@ Formats as: , rest1 } -} -extensionGroup :: Bool -> Box -> Box -> [Box] -> Box -extensionGroup multiline base first rest = - case - ( multiline - , isLine base - , allSingles (first : rest) - ) - of - (False, Right base', Right fields') -> - line $ row - [ punc "{" - , space - , base' - , space - , punc "|" - , space - , row (List.intersperse (row [punc ",", space]) fields') - , space - , punc "}" - ] - - _ -> - stack1 - [ prefix (row [punc "{", space]) base - , stack1 - ( prefix (row [punc "|", space]) first - : map (prefix (row [punc ",", space])) rest) - |> indent - , line $ punc "}" - ] - - -extensionGroup' :: Bool -> Box -> Box -> Box -extensionGroup' multiline base fields = - case - ( multiline - , base - , fields - ) - of - (False, SingleLine base', SingleLine fields') -> - line $ row $ List.intersperse space - [ punc "{" - , base' - , fields' - , punc "}" - ] - - _ -> - stack1 - [ prefix (row [punc "{", space]) base - , indent fields - , line $ punc "}" - ] +extensionGroup :: Text -> Text -> Text -> Text -> Bool -> Elm -> NonEmpty Elm -> [(Elm, NonEmpty Elm)] -> Maybe Elm -> Elm +extensionGroup left delim sep right forceMultiline base section1 sections extraFooter = + Fix $ ExtensionGroup left delim sep right forceMultiline base section1 sections extraFooter + + +{-| +Formats as: + + [a..b] + + [ + a + .. + b + ] +-} +range :: Text -> Text -> Text -> Elm -> Elm -> Elm +range left dots right a b = + Fix $ Range left dots right a b diff --git a/elm-format-lib/src/ElmFormat/Render/Text.hs b/elm-format-lib/src/ElmFormat/Render/Text.hs index adbe83fcb..3eca6a542 100644 --- a/elm-format-lib/src/ElmFormat/Render/Text.hs +++ b/elm-format-lib/src/ElmFormat/Render/Text.hs @@ -1,21 +1,21 @@ -{-# LANGUAGE DataKinds #-} module ElmFormat.Render.Text where -import Data.Coapplicative import Elm.Utils ((|>)) import ElmVersion (ElmVersion) import AST.Structure import AST.V0_16 -import AST.Module (Module) import qualified Box import qualified Data.Text as Text import qualified ElmFormat.Render.Box as Render +import qualified Data.Fix as Fix +import qualified ElmFormat.Render.ElmStructure as ElmStructure +import qualified Data.Indexed as I -render :: Coapplicative annf => ElmVersion -> Module [UppercaseIdentifier] (ASTNS annf [UppercaseIdentifier] 'TopLevelNK) -> Text.Text +render :: ElmVersion -> I.Fix (ASTNS [UppercaseIdentifier]) 'ModuleNK -> Text.Text render elmVersion modu = - renderBox $ Render.formatModule elmVersion True 2 modu + renderBox $ Fix.cata ElmStructure.render $ Render.formatModule elmVersion True 2 modu renderBox :: Box.Box -> Text.Text @@ -27,4 +27,4 @@ renderBox box = -- TODO: remove this and convert the Integration test to a test fixture renderLiteral :: ElmVersion -> LiteralValue -> Text.Text renderLiteral elmVersion literal = - renderBox $ Render.formatLiteral elmVersion literal + renderBox $ Fix.cata ElmStructure.render $ Render.formatLiteral elmVersion literal diff --git a/elm-format-lib/src/ElmVersion.hs b/elm-format-lib/src/ElmVersion.hs index 99a7413ed..0cc77d6a9 100644 --- a/elm-format-lib/src/ElmVersion.hs +++ b/elm-format-lib/src/ElmVersion.hs @@ -11,6 +11,7 @@ data ElmVersion | Elm_0_17 -- TODO: remove 0_17 | Elm_0_18 | Elm_0_19 + deriving (Eq, Ord) instance Show ElmVersion where @@ -29,28 +30,17 @@ parse versionString = _ -> Left ("Invalid Elm version \"" ++ versionString ++ "\". Supported versions are 0.18, 0.19") +syntax_0_18_disallowLiteralRange :: ElmVersion -> Bool +syntax_0_18_disallowLiteralRange = (>= Elm_0_18) + + syntax_0_19_disallowApostropheInVars :: ElmVersion -> Bool -syntax_0_19_disallowApostropheInVars elmVersion = - case elmVersion of - Elm_0_16 -> False - Elm_0_17 -> False - Elm_0_18 -> False - Elm_0_19 -> True +syntax_0_19_disallowApostropheInVars = (>= Elm_0_19) style_0_19_stringEscape :: ElmVersion -> Bool -style_0_19_stringEscape elmVersion = - case elmVersion of - Elm_0_16 -> False - Elm_0_17 -> False - Elm_0_18 -> False - Elm_0_19 -> True +style_0_19_stringEscape = (>= Elm_0_19) style_0_19_cannotExposeOpenListing :: ElmVersion -> Bool -style_0_19_cannotExposeOpenListing elmVersion = - case elmVersion of - Elm_0_16 -> False - Elm_0_17 -> False - Elm_0_18 -> False - Elm_0_19 -> True +style_0_19_cannotExposeOpenListing = (>= Elm_0_19) diff --git a/elm-format-lib/src/Indent.hs b/elm-format-lib/src/Indent.hs new file mode 100644 index 000000000..472986176 --- /dev/null +++ b/elm-format-lib/src/Indent.hs @@ -0,0 +1,64 @@ +module Indent (Indent, tab,spaces,width) where + + +spacesInTab :: Word +spacesInTab = 4 + + +{-| `Indent` represents an indentation level, +and the operator `<>` can be used to combine two indentations side-by-side, accounting for the tab size. + +Each `Indent` can be thought of as: +one or more TABs, followed by zero to three SPACEs. + +Combining two indents can be thought of as +typing the first and then the second sequence of +TABs and SPACEs in a word processor. + +For example: + + [TAB] <> [TAB] == [TAB][TAB] + [TAB] <> ... == [TAB]... + [TAB] <> [TAB]... == [TAB][TAB]... + <> ... == ... + [TAB].. <> [TAB] == [TAB][TAB] + .. <> . == ... + .. <> .. == [TAB] + +-} +newtype Indent = + Indent [Word] + deriving (Semigroup, Monoid, Show) + +instance Eq Indent where + a == b = + width' a == width' b + + +tab :: Indent +tab = Indent [spacesInTab] + + +spaces :: Word -> Indent +spaces = Indent . pure + + +width :: Num n => Indent -> n +width = fromIntegral . width' + + +width' :: Indent -> Word +width' (Indent is) = + foldl combine 0 is + + +combine :: Word -> Word -> Word +combine pos i = + if i < spacesInTab + -- The right side starts with spaces (and no TABs), + -- so just add everything together. + then pos + i + + -- The right side starts with at least one TAB, + -- so remove the trailing spaces from the left. + else pos - (pos `mod` spacesInTab) + i diff --git a/elm-format-lib/src/Parse/Binop.hs b/elm-format-lib/src/Parse/Binop.hs index 4a1a6edb2..cac525f0a 100644 --- a/elm-format-lib/src/Parse/Binop.hs +++ b/elm-format-lib/src/Parse/Binop.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE DataKinds #-} module Parse.Binop (binops) where import Parse.ParsecAdapter ((<|>), choice, try) import AST.V0_16 -import AST.Structure (FixAST) import Data.Coapplicative import qualified Data.Indexed as I import Parse.Helpers (commitIf, addLocation, multilineToBool) @@ -14,17 +12,17 @@ import Reporting.Annotation (Located) binops - :: IParser (FixAST Located typeRef ctorRef varRef 'ExpressionNK) - -> IParser (FixAST Located typeRef ctorRef varRef 'ExpressionNK) - -> IParser varRef - -> IParser (FixAST Located typeRef ctorRef varRef 'ExpressionNK) + :: IParser (I.Fix2 Located (AST p) 'ExpressionNK) + -> IParser (I.Fix2 Located (AST p) 'ExpressionNK) + -> IParser (VarRef p) + -> IParser (I.Fix2 Located (AST p) 'ExpressionNK) binops term last anyOp = - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ do ((e, ops), multiline) <- trackNewline ((,) <$> term <*> nextOps) return $ case ops of [] -> - extract $ I.unFix e + extract $ I.unFix2 e _ -> Binops e ops $ multilineToBool multiline where @@ -32,7 +30,7 @@ binops term last anyOp = choice [ commitIf (whitespace >> anyOp) $ do preOpComments <- whitespace - op <- anyOp + op <- I.Fix2 <$> addLocation (VarRef_ <$> anyOp) preExpressionComments <- whitespace expr <- Left <$> try term <|> Right <$> last case expr of diff --git a/elm-format-lib/src/Parse/Declaration.hs b/elm-format-lib/src/Parse/Declaration.hs index 8b257a45c..e6abaa6f8 100644 --- a/elm-format-lib/src/Parse/Declaration.hs +++ b/elm-format-lib/src/Parse/Declaration.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} module Parse.Declaration where import Parse.ParsecAdapter ( (<|>), (), choice, digit, optionMaybe, string, try ) @@ -16,7 +15,7 @@ import Parse.Whitespace import Reporting.Annotation (Located) -declaration :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'TopLevelDeclarationNK) +declaration :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TopLevelDeclarationNK) declaration elmVersion = typeDecl elmVersion <|> infixDecl elmVersion <|> port elmVersion <|> definition elmVersion @@ -32,9 +31,9 @@ topLevelStructure entry = -- TYPE ANNOTATIONS and DEFINITIONS -definition :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'TopLevelDeclarationNK) +definition :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TopLevelDeclarationNK) definition elmVersion = - fmap I.Fix $ addLocation $ fmap (CommonDeclaration . I.Fix) $ addLocation + fmap I.Fix2 $ addLocation $ fmap (CommonDeclaration . I.Fix2) $ addLocation ( (Expr.typeAnnotation elmVersion TypeAnnotation <|> Expr.definition elmVersion Definition @@ -45,9 +44,9 @@ definition elmVersion = -- TYPE ALIAS and UNION TYPES -typeDecl :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'TopLevelDeclarationNK) +typeDecl :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TopLevelDeclarationNK) typeDecl elmVersion = - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ do try (reserved elmVersion "type") "a type declaration" postType <- forcedWS isAlias <- optionMaybe (string "alias" >> forcedWS) @@ -79,7 +78,7 @@ typeDecl elmVersion = -- INFIX -infixDecl :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'TopLevelDeclarationNK) +infixDecl :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TopLevelDeclarationNK) infixDecl elmVersion = expecting "an infix declaration" $ choice @@ -88,9 +87,9 @@ infixDecl elmVersion = ] -infixDecl_0_19 :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'TopLevelDeclarationNK) +infixDecl_0_19 :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TopLevelDeclarationNK) infixDecl_0_19 elmVersion = - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ let assoc = choice @@ -101,14 +100,14 @@ infixDecl_0_19 elmVersion = in Fixity <$> (try (reserved elmVersion "infix") *> preCommented assoc) - <*> (preCommented $ (\n -> read [n]) <$> digit) - <*> (commented symOpInParens) + <*> preCommented ((\n -> read [n]) <$> digit) + <*> commented symOpInParens <*> (equals *> preCommented (lowVar elmVersion)) -infixDecl_0_16 :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'TopLevelDeclarationNK) +infixDecl_0_16 :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TopLevelDeclarationNK) infixDecl_0_16 elmVersion = - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ do assoc <- choice [ try (reserved elmVersion "infixl") >> return L @@ -118,15 +117,15 @@ infixDecl_0_16 elmVersion = digitComments <- forcedWS n <- digit opComments <- forcedWS - Fixity_until_0_18 assoc digitComments (read [n]) opComments <$> anyOp elmVersion + Fixity_until_0_18 assoc digitComments (read [n]) opComments . I.Fix2 <$> addLocation (VarRef_ <$> anyOp elmVersion) -- PORT -port :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'TopLevelDeclarationNK) +port :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TopLevelDeclarationNK) port elmVersion = expecting "a port declaration" $ - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ do try (reserved elmVersion "port") preNameComments <- whitespace name <- lowVar elmVersion diff --git a/elm-format-lib/src/Parse/Expression.hs b/elm-format-lib/src/Parse/Expression.hs index 77d2cb488..7a5849a11 100644 --- a/elm-format-lib/src/Parse/Expression.hs +++ b/elm-format-lib/src/Parse/Expression.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} module Parse.Expression (term, typeAnnotation, definition, expr) where @@ -27,29 +26,29 @@ import qualified Reporting.Annotation as A -------- Basic Terms -------- -varTerm :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) +varTerm :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK) varTerm elmVersion = - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ let - resolve v = + resolve (A.At at v) = case v of TagRef [] (UppercaseIdentifier "True") -> Literal $ Boolean True TagRef [] (UppercaseIdentifier "False") -> Literal $ Boolean False - _ -> VarExpr v + _ -> VarExpr $ I.Fix2 $ A.At at $ VarRef_ v in - resolve <$> var elmVersion + resolve <$> addLocation (var elmVersion) -accessor :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) +accessor :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK) accessor elmVersion = - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ do lbl <- try (string "." >> rLabel elmVersion) return $ AccessFunction lbl -negative :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) +negative :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK) negative elmVersion = - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ do nTerm <- try $ do _ <- char '-' @@ -61,9 +60,9 @@ negative elmVersion = -------- Complex Terms -------- -listTerm :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) +listTerm :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK) listTerm elmVersion = - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ shader' <|> try (braces range) <|> commaSeparated where range = @@ -71,11 +70,10 @@ listTerm elmVersion = lo <- expr elmVersion (C (loPost, hiPre) _) <- padded (string "..") hi <- expr elmVersion - return $ \loPre hiPost multiline -> + return $ \loPre hiPost _ -> Range (C (loPre, loPost) lo) (C (hiPre, hiPost) hi) - multiline shader' = do rawSrc <- Help.shader @@ -88,9 +86,9 @@ listTerm elmVersion = return $ ExplicitList terms trailing -parensTerm :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) +parensTerm :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK) parensTerm elmVersion = - fmap I.Fix $ + fmap I.Fix2 $ choice [ try (addLocation $ parens' opFn ) , try (addLocation $ parens' tupleFn) @@ -100,7 +98,7 @@ parensTerm elmVersion = ] where opFn = - VarExpr <$> anyOp elmVersion + VarExpr . I.Fix2 <$> addLocation (VarRef_ <$> anyOp elmVersion) tupleFn = do commas <- many1 comma @@ -120,9 +118,9 @@ parensTerm elmVersion = return $ \pre post _ -> Unit (pre ++ post) -recordTerm :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) +recordTerm :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK) recordTerm elmVersion = - fmap I.Fix $ + fmap I.Fix2 $ addLocation $ brackets' $ checkMultiline $ do base <- optionMaybe $ try (commented (lowVar elmVersion) <* string "|") @@ -130,10 +128,10 @@ recordTerm elmVersion = return $ Record base fields trailing -term :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) +term :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK) term elmVersion = (choice - [ fmap I.Fix $ addLocation (Literal <$> Literal.literal) + [ fmap I.Fix2 $ addLocation (Literal <$> Literal.literal) , listTerm elmVersion , accessor elmVersion , negative elmVersion @@ -154,7 +152,7 @@ head' [] = Nothing head' (a:_) = Just a -appExpr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) +appExpr :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK) appExpr elmVersion = expecting "an expression" $ do start <- getPosition @@ -179,12 +177,12 @@ appExpr elmVersion = (JoinAll, JoinAll, False) -> FAJoinFirst JoinAll (JoinAll, SplitAll, _) -> FASplitFirst in - I.Fix $ A.at start end $ App t (fmap fst ts) multiline + I.Fix2 $ A.at start end $ App t (fmap fst ts) multiline -------- Normal Expressions -------- -expr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) +expr :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK) expr elmVersion = choice [ letExpr elmVersion, caseExpr elmVersion, ifExpr elmVersion ] <|> lambdaExpr elmVersion @@ -192,7 +190,7 @@ expr elmVersion = "an expression" -binaryExpr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) +binaryExpr :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK) binaryExpr elmVersion = Binop.binops (appExpr elmVersion) lastExpr (anyOp elmVersion) where @@ -202,14 +200,14 @@ binaryExpr elmVersion = "an expression" -ifExpr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) +ifExpr :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK) ifExpr elmVersion = let elseKeyword = (reserved elmVersion "else" "an 'else' branch") >> whitespace in - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ do first <- ifClause elmVersion rest <- many (try $ C <$> elseKeyword <*> ifClause elmVersion) @@ -218,7 +216,7 @@ ifExpr elmVersion = return $ If first rest final -ifClause :: ElmVersion -> IParser (IfClause (ASTNS Located [UppercaseIdentifier] 'ExpressionNK)) +ifClause :: ElmVersion -> IParser (IfClause (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK)) ifClause elmVersion = do try (reserved elmVersion "if") @@ -232,7 +230,7 @@ ifClause elmVersion = (C (bodyComments, preElse) thenBranch) -lambdaExpr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) +lambdaExpr :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK) lambdaExpr elmVersion = let subparser = do @@ -242,14 +240,14 @@ lambdaExpr elmVersion = body <- expr elmVersion return (args, preArrowComments, bodyComments, body) in - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ do ((args, preArrowComments, bodyComments, body), multiline) <- trackNewline subparser return $ Lambda args (preArrowComments ++ bodyComments) body $ multilineToBool multiline -caseExpr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) +caseExpr :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK) caseExpr elmVersion = - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ do try (reserved elmVersion "case") (e, multilineSubject) <- trackNewline $ padded (expr elmVersion) reserved elmVersion "of" @@ -258,7 +256,7 @@ caseExpr elmVersion = return $ Case (e, multilineToBool multilineSubject) result where case_ preComments = - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ do (patternComments, p, C (preArrowComments, bodyComments) _) <- try ((,,) @@ -272,7 +270,7 @@ caseExpr elmVersion = , beforeArrow = preArrowComments , afterArrow = bodyComments , pattern = p - , body = result + , caseBranchBody = result } cases preComments = @@ -287,17 +285,17 @@ caseExpr elmVersion = -- LET -letExpr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) +letExpr :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK) letExpr elmVersion = - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ do try (reserved elmVersion "let") A.At cal commentsAfterLet' <- addLocation whitespace - let commentsAfterLet = fmap (I.Fix . A.At cal . LetComment) commentsAfterLet' + let commentsAfterLet = fmap (I.Fix2 . A.At cal . LetComment) commentsAfterLet' defs <- block $ - do def <- fmap I.Fix $ addLocation $ fmap (LetCommonDeclaration . I.Fix) $ addLocation (typeAnnotation elmVersion TypeAnnotation <|> definition elmVersion Definition) + do def <- fmap I.Fix2 $ addLocation $ fmap (LetCommonDeclaration . I.Fix2) $ addLocation (typeAnnotation elmVersion TypeAnnotation <|> definition elmVersion Definition) A.At cad commentsAfterDef' <- addLocation whitespace - let commentsAfterDef = fmap (I.Fix . A.At cad . LetComment) commentsAfterDef' + let commentsAfterDef = fmap (I.Fix2 . A.At cad . LetComment) commentsAfterDef' return (def : commentsAfterDef) _ <- reserved elmVersion "in" bodyComments <- whitespace @@ -307,7 +305,7 @@ letExpr elmVersion = -- TYPE ANNOTATION -typeAnnotation :: ElmVersion -> (C1 after (Ref ()) -> C1 before (ASTNS Located [UppercaseIdentifier] 'TypeNK) -> a) -> IParser a +typeAnnotation :: ElmVersion -> (C1 after (Ref ()) -> C1 before (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TypeNK) -> a) -> IParser a typeAnnotation elmVersion fn = (\(v, pre, post) e -> fn (C pre v) (C post e)) <$> try start <*> Type.expr elmVersion where @@ -322,10 +320,10 @@ typeAnnotation elmVersion fn = definition :: ElmVersion -> - (ASTNS Located [UppercaseIdentifier] 'PatternNK - -> [C1 before (ASTNS Located [UppercaseIdentifier] 'PatternNK)] + (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'PatternNK + -> [C1 before (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'PatternNK)] -> Comments - -> (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) + -> (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK) -> a ) -> IParser a @@ -338,18 +336,18 @@ definition elmVersion fn = return $ fn name args (preEqualsComments ++ postEqualsComments) body -defStart :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'PatternNK, [C1 before (ASTNS Located [UppercaseIdentifier] 'PatternNK)]) +defStart :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'PatternNK, [C1 before (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'PatternNK)]) defStart elmVersion = choice [ do pattern <- try $ Pattern.term elmVersion func $ pattern - , do opPattern <- fmap I.Fix $ addLocation (OpPattern <$> parens' symOp) + , do opPattern <- fmap I.Fix2 $ addLocation (OpPattern <$> parens' symOp) func opPattern ] "the definition of a variable (x = ...)" where func pattern = - case extract $ I.unFix pattern of + case extract $ I.unFix2 pattern of VarPattern _ -> ((,) pattern) <$> spacePrefix (Pattern.term elmVersion) diff --git a/elm-format-lib/src/Parse/Helpers.hs b/elm-format-lib/src/Parse/Helpers.hs index 9a07fb75d..fa3dc4c8b 100644 --- a/elm-format-lib/src/Parse/Helpers.hs +++ b/elm-format-lib/src/Parse/Helpers.hs @@ -1,16 +1,13 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} module Parse.Helpers where import Prelude hiding (until) import Control.Monad (guard) import qualified Data.Indexed as I import Data.Map.Strict hiding (foldl) -import Parse.ParsecAdapter hiding (newline, spaces, State) +import Parse.ParsecAdapter import AST.V0_16 import qualified AST.Helpers as Help -import AST.Structure (FixAST) import ElmVersion import qualified Parse.State as State import Parse.Comments @@ -473,7 +470,10 @@ located parser = return (start, value, end) -accessible :: ElmVersion -> IParser (FixAST A.Located typeRef ctorRef varRef 'ExpressionNK) -> IParser (FixAST A.Located typeRef ctorRef varRef 'ExpressionNK) +accessible :: + ElmVersion + -> IParser (I.Fix2 A.Located (AST p) 'ExpressionNK) + -> IParser (I.Fix2 A.Located (AST p) 'ExpressionNK) accessible elmVersion exprParser = do start <- Parsec.getPosition rootExpr <- exprParser @@ -487,7 +487,7 @@ accessible elmVersion exprParser = accessible elmVersion $ do v <- lowVar elmVersion end <- Parsec.getPosition - return $ I.Fix $ A.at start end $ Access rootExpr v + return $ I.Fix2 $ A.at start end $ Access rootExpr v dot :: IParser () diff --git a/elm-format-lib/src/Parse/IParser.hs b/elm-format-lib/src/Parse/IParser.hs index 2625ca564..747344c7b 100644 --- a/elm-format-lib/src/Parse/IParser.hs +++ b/elm-format-lib/src/Parse/IParser.hs @@ -2,6 +2,13 @@ module Parse.IParser where import Parse.Primitives (Parser) import Reporting.Error.Syntax (ParsecError) +import AST.V0_16 (UppercaseIdentifier) +import qualified Data.Indexed as I +import Reporting.Annotation (Located) +import AST.Structure (ASTNS) type IParser a = Parser ParsecError a + + +type ParsedAST = I.Fix2 Located (ASTNS [UppercaseIdentifier]) diff --git a/elm-format-lib/src/Parse/Module.hs b/elm-format-lib/src/Parse/Module.hs index 2dd4bf8ae..13bcd36db 100644 --- a/elm-format-lib/src/Parse/Module.hs +++ b/elm-format-lib/src/Parse/Module.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} module Parse.Module (moduleDecl, elmModule, topLevel, import') where import qualified Control.Applicative @@ -7,34 +7,28 @@ import Elm.Utils ((|>)) import Parse.ParsecAdapter ( char, letter, string, choice, eof, option, optionMaybe, (), (<|>), many, try ) import Parse.Helpers import qualified Parse.Declaration as Decl -import AST.Listing (Listing(..), mergeCommentedMap, mergeListing) -import qualified AST.Listing as Listing -import AST.Module (DetailedListing, Module, ImportMethod) -import qualified AST.Module as Module -import AST.Structure -import AST.V0_16 +import AST.V0_16 hiding (imports) import qualified Data.Indexed as I import ElmVersion import Parse.IParser import Parse.Whitespace -import Reporting.Annotation (Located) +import Reporting.Annotation (Located(At)) -elmModule :: ElmVersion -> IParser (Module [UppercaseIdentifier] (ASTNS Located [UppercaseIdentifier] 'TopLevelNK)) +elmModule :: ElmVersion -> IParser (ParsedAST 'ModuleNK) elmModule elmVersion = + fmap I.Fix2 $ addLocation $ do preModule <- option [] freshLine h <- moduleDecl elmVersion preDocsComments <- option [] freshLine (docs, postDocsComments) <- choice - [ (,) <$> addLocation (Just <$> docCommentAsMarkdown) <*> freshLine - , (,) <$> addLocation (return Nothing) <*> return [] + [ (,) <$> (Just <$> docCommentAsMarkdown) <*> freshLine + , return (Nothing, []) ] (preImportComments, imports', postImportComments) <- imports elmVersion topLevels <- - fmap I.Fix $ - addLocation $ - fmap TopLevel $ + fmap I.Fix2 $ addLocation $ fmap ModuleBody $ do decls <- topLevel $ Decl.declaration elmVersion trailingComments <- @@ -42,10 +36,10 @@ elmModule elmVersion = <$> option [] freshLine <*> option [] spaces eof - return ((map BodyComment postImportComments) ++ decls ++ (map BodyComment trailingComments)) + return (fmap BodyComment postImportComments ++ decls ++ fmap BodyComment trailingComments) return $ - Module.Module + Module preModule h docs @@ -55,7 +49,7 @@ elmModule elmVersion = topLevel :: IParser a -> IParser [TopLevelStructure a] topLevel entry = - (++) <$> option [] (((\x -> [x]) <$> Decl.topLevelStructure entry)) + (++) <$> option [] (pure <$> Decl.topLevelStructure entry) <*> (concat <$> many (freshDef entry)) @@ -64,10 +58,10 @@ freshDef entry = commitIf (freshLine >> (letter <|> char '_')) $ do comments <- freshLine decl <- Decl.topLevelStructure entry - return $ (map BodyComment comments) ++ [decl] + return $ fmap BodyComment comments ++ [decl] -moduleDecl :: ElmVersion -> IParser (Maybe Module.Header) +moduleDecl :: ElmVersion -> IParser (Maybe (ParsedAST 'ModuleHeaderNK)) moduleDecl elmVersion = choice [ try $ Just <$> moduleDecl_0_16 elmVersion @@ -76,34 +70,36 @@ moduleDecl elmVersion = ] -moduleDecl_0_16 :: ElmVersion -> IParser Module.Header +moduleDecl_0_16 :: ElmVersion -> IParser (ParsedAST 'ModuleHeaderNK) moduleDecl_0_16 elmVersion = expecting "a module declaration" $ + fmap I.Fix2 $ addLocation $ do try (reserved elmVersion "module") preName <- whitespace names <- dotSep1 (capVar elmVersion) "the name of this module" postName <- whitespace - exports <- option (OpenListing (C ([], []) ())) (listing $ detailedListing elmVersion) + exports <- fmap I.Fix2 $ addLocation $ ModuleListing <$> option (OpenListing (C ([], []) ())) (listing $ detailedListing elmVersion) preWhere <- whitespace reserved elmVersion "where" return $ - Module.Header - Module.Normal + ModuleHeader + Normal (C (preName, postName) names) Nothing (Just $ C (preWhere, []) exports) -moduleDecl_0_17 :: ElmVersion -> IParser Module.Header +moduleDecl_0_17 :: ElmVersion -> IParser (ParsedAST 'ModuleHeaderNK) moduleDecl_0_17 elmVersion = expecting "a module declaration" $ + fmap I.Fix2 $ addLocation $ do srcTag <- try $ choice - [ Module.Port <$> (reserved elmVersion "port" *> whitespace) - , Module.Effect <$> (reserved elmVersion "effect" *> whitespace) - , return Module.Normal + [ Port <$> (reserved elmVersion "port" *> whitespace) + , Effect <$> (reserved elmVersion "effect" *> whitespace) + , return Normal ] <* reserved elmVersion "module" preName <- whitespace @@ -115,63 +111,70 @@ moduleDecl_0_17 elmVersion = exports <- optionMaybe $ - commentedKeyword elmVersion "exposing" (listing $ detailedListing elmVersion) + commentedKeyword elmVersion "exposing" (fmap I.Fix2 $ addLocation $ fmap ModuleListing $ listing $ detailedListing elmVersion) <|> try (listingWithoutExposing elmVersion) return $ - Module.Header + ModuleHeader srcTag (C (preName, []) names) whereClause exports -listingWithoutExposing :: ElmVersion -> IParser (C2 beforeKeyword afterKeyword (Listing DetailedListing)) +listingWithoutExposing :: ElmVersion -> IParser (C2 beforeKeyword afterKeyword (ParsedAST 'ModuleListingNK)) listingWithoutExposing elmVersion = do let pre = [] post <- whitespace - C (pre, post) <$> listing (detailedListing elmVersion) + C (pre, post) <$> fmap I.Fix2 (addLocation $ ModuleListing <$> listing (detailedListing elmVersion)) mergePreCommented :: (a -> a -> a) -> C1 before a -> C1 before a -> C1 before a mergePreCommented merge (C pre1 left) (C pre2 right) = C (pre1 ++ pre2) (merge left right) -mergeC2 :: (a -> b -> c) -> C2 before after a -> C2 before after b -> C2 before after c -mergeC2 merge (C (pre1, post1) left) (C (pre2, post2) right) = - C (pre1 ++ pre2, post1 ++ post2) (merge left right) - -mergeDetailedListing :: Module.DetailedListing -> Module.DetailedListing -> Module.DetailedListing +mergeDetailedListing :: DetailedListing -> DetailedListing -> DetailedListing mergeDetailedListing left right = - Module.DetailedListing - (mergeCommentedMap (<>) (Module.values left) (Module.values right)) - (mergeCommentedMap (<>) (Module.operators left) (Module.operators right)) - (mergeCommentedMap (mergePreCommented $ mergeListing $ mergeCommentedMap (<>)) (Module.types left) (Module.types right)) + DetailedListing + (mergeCommentedMap (<>) (values left) (values right)) + (mergeCommentedMap (<>) (operators left) (operators right)) + (mergeCommentedMap (mergePreCommented $ mergeListing $ mergeCommentedMap (<>)) (types left) (types right)) -imports :: ElmVersion -> IParser (Comments, Map [UppercaseIdentifier] (C1 'BeforeTerm ImportMethod), Comments) +imports :: ElmVersion -> IParser (Comments, Map [UppercaseIdentifier] (C1 'BeforeTerm (ParsedAST 'ImportMethodNK)), Comments) imports elmVersion = let - merge :: C1 'BeforeTerm ImportMethod -> C1 'BeforeTerm ImportMethod -> C1 'BeforeTerm ImportMethod - merge (C comments1 import1) (C comments2 import2) = - C (comments1 ++ comments2) $ - Module.ImportMethod - (Module.alias import1 Control.Applicative.<|> Module.alias import2) - (mergeC2 (mergeListing mergeDetailedListing) (Module.exposedVars import1) (Module.exposedVars import2)) - - step (comments, m, finalComments) (((C pre name), method), post) = + merge :: + C1 'BeforeTerm (ParsedAST 'ImportMethodNK) + -> C1 'BeforeTerm (ParsedAST 'ImportMethodNK) + -> C1 'BeforeTerm (ParsedAST 'ImportMethodNK) + merge (C comments1 (I.Fix2 (At region (ImportMethod as1 (C (preSep1, postSep1) (I.Fix2 (At importsRegion (ModuleListing imports1)))))))) (C comments2 (I.Fix2 (At _ (ImportMethod as2 (C (preSep2, postSep2) (I.Fix2 (At _ (ModuleListing imports2)))))))) = + C (comments1 ++ comments2) $ I.Fix2 $ At region $ + ImportMethod + (as1 Control.Applicative.<|> as2) + (C (preSep1 ++ preSep2, postSep1 ++ postSep2) $ I.Fix2 $ At importsRegion $ ModuleListing $ mergeListing mergeDetailedListing imports1 imports2) + + step (comments, m, finalComments) ((C pre name, method), post) = ( comments ++ finalComments , insertWith merge name (C pre method) m , post ) - done :: [(Module.UserImport, Comments)] -> (Comments, Map [UppercaseIdentifier] (C1 'BeforeTerm ImportMethod), Comments) - done results = - foldl step ([], empty, []) results + done :: + [(UserImport, Comments)] + -> (Comments, Map [UppercaseIdentifier] (C1 'BeforeTerm (ParsedAST 'ImportMethodNK)), Comments) + done = + foldl step ([], empty, []) in done <$> many ((,) <$> import' elmVersion <*> freshLine) -import' :: ElmVersion -> IParser Module.UserImport +type UserImport = + ( C1 'BeforeTerm [UppercaseIdentifier] + , ParsedAST 'ImportMethodNK + ) + + +import' :: ElmVersion -> IParser ( C1 'BeforeTerm [UppercaseIdentifier], ParsedAST 'ImportMethodNK) import' elmVersion = expecting "an import" $ do try (reserved elmVersion "import") @@ -180,11 +183,17 @@ import' elmVersion = method' <- method names return (C preName names, method') where - method :: [UppercaseIdentifier] -> IParser Module.ImportMethod + method :: [UppercaseIdentifier] -> IParser (ParsedAST 'ImportMethodNK) method originalName = - Module.ImportMethod + fmap I.Fix2 $ addLocation $ + ImportMethod <$> option Nothing (Just <$> as' originalName) - <*> option (C ([], []) ClosedListing) (exposing <|> try (listingWithoutExposing elmVersion)) + <*> choice + [ exposing + , try (listingWithoutExposing elmVersion) + , fmap (C ([], []) . I.Fix2) $ addLocation $ pure $ ModuleListing ClosedListing + ] + -- <*> fmap (fmap I.Fix2 . sequenceA) (addLocation $ fmap ModuleListing <$> option (C ([], []) ClosedListing) (exposing <|> try (listingWithoutExposing elmVersion))) as' :: [UppercaseIdentifier] -> IParser (C2 'BeforeSeparator 'AfterSeparator UppercaseIdentifier) as' moduleName = @@ -192,15 +201,15 @@ import' elmVersion = postAs <- whitespace C (preAs, postAs) <$> capVar elmVersion ("an alias for module `" ++ show moduleName ++ "`") -- TODO: do something correct instead of show - exposing :: IParser (C2 'BeforeSeparator 'AfterSeparator (Listing Module.DetailedListing)) + exposing :: IParser (C2 'BeforeSeparator 'AfterSeparator (ParsedAST 'ModuleListingNK)) exposing = do preExposing <- try (whitespace <* reserved elmVersion "exposing") postExposing <- whitespace imports <- - choice - [ listing $ detailedListing elmVersion - , listingWithoutParens elmVersion - ] + fmap I.Fix2 $ addLocation $ ModuleListing <$> choice + [ listing $ detailedListing elmVersion + , listingWithoutParens elmVersion + ] return $ C (preExposing, postExposing) imports @@ -208,8 +217,8 @@ listing :: IParser (Comments -> Comments -> a) -> IParser (Listing a) listing explicit = let subparser = choice - [ (\_ pre post _ -> (OpenListing (C (pre, post) ()))) <$> string ".." - , (\x pre post sawNewline -> (ExplicitListing (x pre post) sawNewline)) <$> + [ (\_ pre post _ -> OpenListing (C (pre, post) ())) <$> string ".." + , (\x pre post sawNewline -> ExplicitListing (x pre post) sawNewline) <$> explicit ] in @@ -220,28 +229,28 @@ listing explicit = return $ listing pre post $ multilineToBool multiline -listingWithoutParens :: ElmVersion -> IParser (Listing Module.DetailedListing) +listingWithoutParens :: ElmVersion -> IParser (Listing DetailedListing) listingWithoutParens elmVersion = expecting "a listing of values and types to expose, but with missing parentheses" $ choice - [ (\_ -> (OpenListing (C ([], []) ()))) <$> string ".." - , (\x -> (ExplicitListing (x [] []) False)) <$> detailedListing elmVersion + [ (\_ -> OpenListing (C ([], []) ())) <$> string ".." + , (\x -> ExplicitListing (x [] []) False) <$> detailedListing elmVersion ] -commentedSet :: Ord a => IParser a -> IParser (Comments -> Comments -> Listing.CommentedMap a ()) +commentedSet :: Ord a => IParser a -> IParser (Comments -> Comments -> CommentedMap a ()) commentedSet item = commaSep1Set' ((\x -> (x, ())) <$> item) (\() () -> ()) -detailedListing :: ElmVersion -> IParser (Comments -> Comments -> Module.DetailedListing) +detailedListing :: ElmVersion -> IParser (Comments -> Comments -> DetailedListing) detailedListing elmVersion = do values <- commaSep1' (value elmVersion) return $ \pre post -> toDetailedListing $ values pre post -toDetailedListing :: [C2 before after Listing.Value] -> Module.DetailedListing +toDetailedListing :: [C2 before after ListingValue] -> DetailedListing toDetailedListing values = let merge @@ -254,30 +263,30 @@ toDetailedListing values = step (vs, os, ts) (C (pre, post) val) = case val of - Listing.Value name -> + Value name -> (insert name (C (pre, post) ()) vs, os, ts) - Listing.OpValue name -> + OpValue name -> (vs, insert name (C (pre, post) ()) os, ts) - Listing.Union (C inner name) tags -> + Union (C inner name) tags -> (vs, os, insertWith merge name (C (pre, post) (C inner tags)) ts) done (vs, os, ts) = - Module.DetailedListing vs os ts + DetailedListing vs os ts in foldl step (empty, empty, empty) values |> done -value :: ElmVersion -> IParser Listing.Value +value :: ElmVersion -> IParser ListingValue value elmVersion = val <|> tipe "a value or type to expose" where val = - (Listing.Value <$> lowVar elmVersion) <|> (Listing.OpValue <$> parens' symOp) + (Value <$> lowVar elmVersion) <|> (OpValue <$> parens' symOp) tipe = do name <- capVar elmVersion maybeCtors <- optionMaybe (try $ (,) <$> whitespace <*> listing (commentedSet $ capVar elmVersion)) case maybeCtors of - Nothing -> return $ Listing.Union (C [] name) Listing.ClosedListing - Just (pre, ctors) -> return (Listing.Union (C pre name) ctors) + Nothing -> return $ Union (C [] name) ClosedListing + Just (pre, ctors) -> return (Union (C pre name) ctors) diff --git a/elm-format-lib/src/Parse/Number.hs b/elm-format-lib/src/Parse/Number.hs index 68d97bef3..3f4501247 100644 --- a/elm-format-lib/src/Parse/Number.hs +++ b/elm-format-lib/src/Parse/Number.hs @@ -1,7 +1,6 @@ -- This module is based on `Parse.Number` in the Elm compiler -- https://github.com/elm/compiler/blob/94715a520f499591ac6901c8c822bc87cd1af24f/compiler/src/Parse/Number.hs -{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE BangPatterns, UnboxedTuples #-} module Parse.Number ( Number(..) diff --git a/elm-format-lib/src/Parse/Parse.hs b/elm-format-lib/src/Parse/Parse.hs index a486866f1..a47af3c4f 100644 --- a/elm-format-lib/src/Parse/Parse.hs +++ b/elm-format-lib/src/Parse/Parse.hs @@ -1,36 +1,32 @@ -{-# LANGUAGE DataKinds #-} module Parse.Parse (parse, parseModule, parseDeclarations, parseExpressions) where import Parse.ParsecAdapter (eof) import qualified Parse.ParsecAdapter as Parsec import AST.V0_16 -import AST.Module (Module) -import AST.Structure import ElmVersion hiding (parse) import Parse.Comments (withEol) import qualified Parse.Declaration import qualified Parse.Expression import Parse.Helpers import qualified Parse.Module -import Reporting.Annotation (Located) import qualified Reporting.Annotation as A import qualified Reporting.Error.Syntax as Error import qualified Reporting.Result as Result import Parse.IParser -parseModule :: ElmVersion -> String -> Result.Result () Error.Error (Module [UppercaseIdentifier] (ASTNS Located [UppercaseIdentifier] 'TopLevelNK)) +parseModule :: ElmVersion -> String -> Result.Result () Error.Error (ParsedAST 'ModuleNK) parseModule elmVersion src = parse src (Parse.Module.elmModule elmVersion) -parseDeclarations :: ElmVersion -> String -> Result.Result () Error.Error [TopLevelStructure (ASTNS Located [UppercaseIdentifier] 'TopLevelDeclarationNK)] +parseDeclarations :: ElmVersion -> String -> Result.Result () Error.Error [TopLevelStructure (ParsedAST 'TopLevelDeclarationNK)] parseDeclarations elmVersion src = parse src (Parse.Module.topLevel (Parse.Declaration.declaration elmVersion) <* eof) -parseExpressions :: ElmVersion -> String -> Result.Result () Error.Error [TopLevelStructure (C0Eol (ASTNS Located [UppercaseIdentifier] 'ExpressionNK))] +parseExpressions :: ElmVersion -> String -> Result.Result () Error.Error [TopLevelStructure (C0Eol (ParsedAST 'ExpressionNK))] parseExpressions elmVersion src = parse src (Parse.Module.topLevel (withEol $ Parse.Expression.expr elmVersion) <* eof) @@ -45,6 +41,6 @@ parse source parser = Left err -> let - pos = (Parsec.errorPos err) + pos = Parsec.errorPos err in Result.throw (A.Region pos pos) (Error.Parse err) diff --git a/elm-format-lib/src/Parse/Pattern.hs b/elm-format-lib/src/Parse/Pattern.hs index 98a38acf1..5eecb05bd 100644 --- a/elm-format-lib/src/Parse/Pattern.hs +++ b/elm-format-lib/src/Parse/Pattern.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} module Parse.Pattern (term, expr) where import Parse.ParsecAdapter ((<|>), (), char, choice, optionMaybe, try) @@ -16,31 +15,34 @@ import Parse.Whitespace import qualified Parse.ParsecAdapter as Parsec -basic :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'PatternNK) +basic :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'PatternNK) basic elmVersion = - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ choice [ char '_' >> return Anything , VarPattern <$> lowVar elmVersion - , chunksToPattern <$> dotSep1 (capVar elmVersion) + , chunksToPattern <$> addLocation (dotSep1 (capVar elmVersion)) , LiteralPattern <$> Literal.literal ] where chunksToPattern chunks = - case reverse chunks of - [UppercaseIdentifier "True"] -> + case reverse <$> chunks of + A.At _ [UppercaseIdentifier "True"] -> LiteralPattern (Boolean True) - [UppercaseIdentifier "False"] -> + A.At _ [UppercaseIdentifier "False"] -> LiteralPattern (Boolean False) - (last:rest) -> - DataPattern (reverse rest, last) [] + A.At at (last:rest) -> + DataPattern (I.Fix2 $ A.At at $ CtorRef_ (reverse rest, last)) [] - [] -> error "dotSep1 returned empty list" + A.At _ [] -> error "dotSep1 returned empty list" -asPattern :: ElmVersion -> IParser (FixAST Located typeRef ctorRef varRef 'PatternNK) -> IParser (FixAST Located typeRef ctorRef varRef 'PatternNK) +asPattern :: + ElmVersion + -> IParser (I.Fix2 Located (AST p) 'PatternNK) + -> IParser (I.Fix2 Located (AST p) 'PatternNK) asPattern elmVersion patternParser = do (start, pattern, _) <- located patternParser @@ -49,7 +51,7 @@ asPattern elmVersion patternParser = case maybeAlias of Just (postPattern, alias) -> do end <- Parsec.getPosition - return $ I.Fix $ A.at start end $ Alias (C postPattern pattern) alias + return $ I.Fix2 $ A.at start end $ Alias (C postPattern pattern) alias Nothing -> return pattern @@ -61,9 +63,9 @@ asPattern elmVersion patternParser = return (preAs, C postAs var) -record :: ElmVersion -> IParser (FixAST Located typeRef ctorRef varRef 'PatternNK) +record :: ElmVersion -> IParser (I.Fix2 Located (AST p) 'PatternNK) record elmVersion = - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ do result <- surround'' '{' '}' (lowVar elmVersion) return $ @@ -74,31 +76,31 @@ record elmVersion = RecordPattern fields -tuple :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'PatternNK) +tuple :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'PatternNK) tuple elmVersion = do (start, patterns, end) <- located $ parens'' (expr elmVersion) return $ case patterns of Left comments -> - I.Fix $ A.at start end $ UnitPattern comments + I.Fix2 $ A.at start end $ UnitPattern comments Right [] -> - I.Fix $ A.at start end $ UnitPattern [] + I.Fix2 $ A.at start end $ UnitPattern [] Right [C ([], []) pattern] -> pattern Right [pattern] -> - I.Fix $ A.at start end $ PatternParens pattern + I.Fix2 $ A.at start end $ PatternParens pattern Right patterns -> - I.Fix $ A.at start end $ TuplePattern patterns + I.Fix2 $ A.at start end $ TuplePattern patterns -list :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'PatternNK) +list :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'PatternNK) list elmVersion = - fmap I.Fix $ addLocation $ + fmap I.Fix2 $ addLocation $ do result <- braces'' (expr elmVersion) return $ @@ -109,24 +111,24 @@ list elmVersion = ListPattern patterns -term :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'PatternNK) +term :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'PatternNK) term elmVersion = choice [ record elmVersion, tuple elmVersion, list elmVersion, basic elmVersion ] "a pattern" -patternConstructor :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'PatternNK) +patternConstructor :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'PatternNK) patternConstructor elmVersion = - fmap I.Fix $ addLocation $ - do v <- dotSep1 (capVar elmVersion) - case reverse v of - [UppercaseIdentifier "True"] -> return $ LiteralPattern (Boolean True) - [UppercaseIdentifier "False"] -> return $ LiteralPattern (Boolean False) - (last:rest) -> DataPattern (reverse rest, last) <$> spacePrefix (term elmVersion) - [] -> error "dotSep1 returned empty list" + fmap I.Fix2 $ addLocation $ + do v <- addLocation $ dotSep1 (capVar elmVersion) + case reverse <$> v of + A.At _ [UppercaseIdentifier "True"] -> return $ LiteralPattern (Boolean True) + A.At _ [UppercaseIdentifier "False"] -> return $ LiteralPattern (Boolean False) + A.At at (last:rest) -> DataPattern (I.Fix2 $ A.At at $ CtorRef_ (reverse rest, last)) <$> spacePrefix (term elmVersion) + A.At _ [] -> error "dotSep1 returned empty list" -expr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'PatternNK) +expr :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'PatternNK) expr elmVersion = asPattern elmVersion subPattern "a pattern" where @@ -138,4 +140,4 @@ expr elmVersion = Left pattern -> pattern Right (region, first, rest, _) -> - I.Fix $ A.At region $ ConsPattern first rest + I.Fix2 $ A.At region $ ConsPattern first rest diff --git a/elm-format-lib/src/Parse/Primitives.hs b/elm-format-lib/src/Parse/Primitives.hs index 5ccae10bc..a9600a761 100644 --- a/elm-format-lib/src/Parse/Primitives.hs +++ b/elm-format-lib/src/Parse/Primitives.hs @@ -2,7 +2,7 @@ -- https://github.com/elm/compiler/blob/94715a520f499591ac6901c8c822bc87cd1af24f/compiler/src/Parse/Primitives.hs {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-} -{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-} +{-# LANGUAGE BangPatterns, Rank2Types #-} module Parse.Primitives -- ( fromByteString ( Parser(..) @@ -27,8 +27,7 @@ import qualified Data.ByteString.Internal as B import Data.Word (Word8, Word16) import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (peek) -import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import Foreign.ForeignPtr (ForeignPtr) import qualified Reporting.Annotation as A @@ -75,8 +74,8 @@ instance Functor (Parser x) where fmap f (Parser parser) = Parser $ \state cok eok cerr eerr -> let - cok' a s = cok (f a) s - eok' a s = eok (f a) s + cok' a = cok (f a) + eok' a = eok (f a) in parser state cok' eok' cerr eerr @@ -95,14 +94,14 @@ instance Applicative.Applicative (Parser x) where let cokF func s1 = let - cokA arg s2 = cok (func arg) s2 + cokA arg = cok (func arg) in parserArg s1 cokA cokA cerr cerr eokF func s1 = let - cokA arg s2 = cok (func arg) s2 - eokA arg s2 = eok (func arg) s2 + cokA arg = cok (func arg) + eokA arg = eok (func arg) in parserArg s1 cokA eokA cerr eerr in @@ -406,4 +405,4 @@ getCharWidth word | word < 0xe0 = 2 | word < 0xf0 = 3 | word < 0xf8 = 4 - | True = error "Need UTF-8 encoded input. Ran into unrecognized bits." + | otherwise = error "Need UTF-8 encoded input. Ran into unrecognized bits." diff --git a/elm-format-lib/src/Parse/Type.hs b/elm-format-lib/src/Parse/Type.hs index 257ff5c6d..4b81b695c 100644 --- a/elm-format-lib/src/Parse/Type.hs +++ b/elm-format-lib/src/Parse/Type.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} module Parse.Type where import Parse.ParsecAdapter ((<|>), (), char, many1, string, try, optionMaybe) @@ -13,17 +12,18 @@ import qualified Data.Indexed as I import ElmVersion import Parse.IParser import Parse.Common +import Data.List.NonEmpty (NonEmpty(..)) -tvar :: ElmVersion -> IParser (FixAST Located typeRef ctorRef varRef 'TypeNK) +tvar :: ElmVersion -> IParser (I.Fix2 Located (AST p) 'TypeNK) tvar elmVersion = - fmap I.Fix $ addLocation + fmap I.Fix2 $ addLocation (TypeVariable <$> lowVar elmVersion "a type variable") -tuple :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'TypeNK) +tuple :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TypeNK) tuple elmVersion = - fmap I.Fix $ addLocation $ checkMultiline $ + fmap I.Fix2 $ addLocation $ checkMultiline $ do types <- parens'' (withEol $ expr elmVersion) return $ case types of @@ -32,16 +32,16 @@ tuple elmVersion = Right [] -> \_ -> UnitType [] Right [C ([], []) (C Nothing t)] -> - \_ -> extract $ I.unFix t + \_ -> extract $ I.unFix2 t Right [C (pre, post) (C eol t)] -> \_ -> TypeParens $ C (pre, eolToComment eol ++ post) t - Right types' -> - TupleType $ fmap (\(C (pre, post) (C eol t)) -> C (pre, post, eol) t) types' + Right (typ0:typ1:typs) -> + TupleType $ (\(C (pre, post) (C eol t)) -> C (pre, post, eol) t) <$> typ0:|typ1:typs -record :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'TypeNK) +record :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TypeNK) record elmVersion = - fmap I.Fix $ addLocation $ brackets' $ checkMultiline $ + fmap I.Fix2 $ addLocation $ brackets' $ checkMultiline $ do base' <- optionMaybe $ try (commented (lowVar elmVersion) <* string "|") (fields', trailing) <- sectionedGroup (pair (lowVar elmVersion) lenientHasType (expr elmVersion)) @@ -53,23 +53,23 @@ capTypeVar elmVersion = dotSep1 (capVar elmVersion) -constructor0 :: ElmVersion -> IParser (TypeConstructor ([UppercaseIdentifier], UppercaseIdentifier)) +constructor0 :: ElmVersion -> IParser (TypeConstructor (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TypeRefNK)) constructor0 elmVersion = - do name <- capTypeVar elmVersion - case reverse name of - [] -> error "Impossible empty TypeConstructor name" - last':rest' -> - return (NamedConstructor (reverse rest', last')) + do name <- addLocation (capTypeVar elmVersion) + case reverse <$> name of + A.At _ [] -> error "Impossible empty TypeConstructor name" + A.At at (last':rest') -> + return (NamedConstructor $ I.Fix2 $ A.At at $ TypeRef_ (reverse rest', last')) -constructor0' :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'TypeNK) +constructor0' :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TypeNK) constructor0' elmVersion = - fmap I.Fix $ addLocation $ checkMultiline $ + fmap I.Fix2 $ addLocation $ checkMultiline $ do ctor <- constructor0 elmVersion return (TypeConstruction ctor []) -term :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'TypeNK) +term :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TypeNK) term elmVersion = tuple elmVersion <|> record elmVersion <|> tvar elmVersion <|> constructor0' elmVersion @@ -80,15 +80,15 @@ tupleCtor = return (TupleConstructor (length ctor + 1)) -app :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'TypeNK) +app :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TypeNK) app elmVersion = - fmap I.Fix $ addLocation $ checkMultiline $ + fmap I.Fix2 $ addLocation $ checkMultiline $ do f <- constructor0 elmVersion <|> try tupleCtor "a type constructor" args <- spacePrefix (term elmVersion) return $ TypeConstruction f args -expr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'TypeNK) +expr :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TypeNK) expr elmVersion = do result <- separated rightArrow (app elmVersion <|> term elmVersion) @@ -97,17 +97,17 @@ expr elmVersion = Left t -> t Right (region, first', rest', multiline) -> - I.Fix $ A.At region $ FunctionType first' rest' (ForceMultiline multiline) + I.Fix2 $ A.At region $ FunctionType first' rest' (ForceMultiline multiline) -- TODO: can this be removed? (tag is the new name?) -constructor :: ElmVersion -> IParser ([UppercaseIdentifier], [C1 before (ASTNS Located [UppercaseIdentifier] 'TypeNK)]) +constructor :: ElmVersion -> IParser ([UppercaseIdentifier], [C1 before (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TypeNK)]) constructor elmVersion = (,) <$> (capTypeVar elmVersion "another type constructor") <*> spacePrefix (term elmVersion) -tag :: ElmVersion -> IParser (NameWithArgs UppercaseIdentifier (ASTNS Located [UppercaseIdentifier] 'TypeNK)) +tag :: ElmVersion -> IParser (NameWithArgs UppercaseIdentifier (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TypeNK)) tag elmVersion = NameWithArgs <$> (capVar elmVersion "another type constructor") diff --git a/elm-format-lib/src/Parse/Whitespace.hs b/elm-format-lib/src/Parse/Whitespace.hs index 84f15475a..103633b63 100644 --- a/elm-format-lib/src/Parse/Whitespace.hs +++ b/elm-format-lib/src/Parse/Whitespace.hs @@ -7,7 +7,7 @@ import Parse.IParser import qualified Parse.Markdown as Markdown import qualified Parse.State as State import qualified Reporting.Error.Syntax as Syntax -import Parse.ParsecAdapter hiding (newline, spaces, State) +import Parse.ParsecAdapter padded :: IParser a -> IParser (C2 before after a) diff --git a/elm-format-lib/src/Reporting/Annotation.hs b/elm-format-lib/src/Reporting/Annotation.hs index 423c9a11f..2d2e52616 100644 --- a/elm-format-lib/src/Reporting/Annotation.hs +++ b/elm-format-lib/src/Reporting/Annotation.hs @@ -1,7 +1,6 @@ -- This module is copied from the Elm compiler with small changes -- https://github.com/elm/compiler/blob/94715a520f499591ac6901c8c822bc87cd1af24f/compiler/src/Reporting/Annotation.hs -{-# OPTIONS_GHC -Wall #-} module Reporting.Annotation ( Located(..) , Position(..) @@ -21,7 +20,6 @@ import Control.Monad (liftM2) import Data.Coapplicative import Data.Binary (Binary, get, put) import Data.Word (Word16) -import Data.String (unwords) @@ -50,7 +48,7 @@ instance Foldable Located where instance Traversable Located where - traverse f (At region a) = fmap (At region) $ f a + traverse f (At region a) = At region <$> f a instance Coapplicative Located where @@ -58,10 +56,6 @@ instance Coapplicative Located where {-# INLINE extract #-} -traverse :: (Functor f) => (a -> f b) -> Located a -> f (Located b) -traverse func (At region value) = - At region <$> func value - toValue :: Located a -> a toValue (At _ value) = @@ -69,8 +63,8 @@ toValue (At _ value) = merge :: Located a -> Located b -> value -> Located value -merge (At r1 _) (At r2 _) value = - At (mergeRegions r1 r2) value +merge (At r1 _) (At r2 _) = + At (mergeRegions r1 r2) @@ -85,8 +79,8 @@ data Position = at :: Position -> Position -> a -> Located a -at start end a = - At (Region start end) a +at start end = + At (Region start end) @@ -136,4 +130,3 @@ instance Binary Region where instance Binary Position where put (Position a b) = put a >> put b get = liftM2 Position get get - diff --git a/elm-format-lib/src/Reporting/Error/Helpers.hs b/elm-format-lib/src/Reporting/Error/Helpers.hs index e2d4a1585..fd9619d81 100644 --- a/elm-format-lib/src/Reporting/Error/Helpers.hs +++ b/elm-format-lib/src/Reporting/Error/Helpers.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wall #-} module Reporting.Error.Helpers where import Data.Function (on) diff --git a/elm-format-lib/src/Reporting/Error/Syntax.hs b/elm-format-lib/src/Reporting/Error/Syntax.hs index c27cd9223..5933cad7e 100644 --- a/elm-format-lib/src/Reporting/Error/Syntax.hs +++ b/elm-format-lib/src/Reporting/Error/Syntax.hs @@ -1,7 +1,6 @@ -- This module is based on `Reporting.Error.Syntax` in the Elm compiler -- https://github.com/elm/compiler/blob/94715a520f499591ac6901c8c822bc87cd1af24f/compiler/src/Reporting/Error/Syntax.hs -{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE OverloadedStrings #-} module Reporting.Error.Syntax ( Error(..) diff --git a/elm-format-lib/test/AST/MatchReferencesTest.hs b/elm-format-lib/test/AST/MatchReferencesSpec.hs similarity index 70% rename from elm-format-lib/test/AST/MatchReferencesTest.hs rename to elm-format-lib/test/AST/MatchReferencesSpec.hs index df235e0fd..70a435e56 100644 --- a/elm-format-lib/test/AST/MatchReferencesTest.hs +++ b/elm-format-lib/test/AST/MatchReferencesSpec.hs @@ -1,15 +1,12 @@ -{-# LANGUAGE DataKinds #-} -module AST.MatchReferencesTest (test_tests) where +module AST.MatchReferencesSpec (spec) where import Elm.Utils ((|>)) import AST.V0_16 import AST.MatchReferences -import AST.Module (ImportMethod(..)) import AST.Structure import Data.Functor.Identity import qualified Data.Indexed as I -import Expect import ElmFormat.ImportInfo (ImportInfo) import qualified ElmFormat.KnownContents as KnownContents import ElmVersion @@ -17,16 +14,15 @@ import qualified ElmFormat.ImportInfo as ImportInfo import qualified Parse.Module import qualified Parse.Parse as Parse import qualified Reporting.Result as Result -import Test.Tasty -import Test.Tasty.HUnit +import Test.Hspec import qualified Data.Map as Dict import Data.List.Split (splitOn) +import Data.Coapplicative (extract) -test_tests :: TestTree -test_tests = - testGroup "AST.MatchReferences" - [ testGroup "matchReferences" $ +spec :: Spec +spec = describe "AST.MatchReferences" $ do + describe "matchReferences" $ let test :: String @@ -35,61 +31,62 @@ test_tests = -> List String -- locals -> Ref [String] -> Ref (MatchedNamespace [String]) - -> TestTree + -> SpecWith () test name knownContents imports locals sourceAst' matchedAst' = let sourceAst = fmap (fmap UppercaseIdentifier) sourceAst' matchedAst = fmap (fmap $ fmap UppercaseIdentifier) matchedAst' + wrapExpr :: (Ref ns -> I.Fix2 Identity (AST (VariableNamespace ns)) 'ExpressionNK) wrapExpr r = case locals of [] -> -- no locals to define, so just make a var expression - I.Fix $ Identity $ VarExpr r + I.Fix2 $ Identity $ VarExpr $ I.Fix2 $ Identity $ VarRef_ r _ -> -- define the provided locals in a let block - I.Fix $ Identity $ + I.Fix2 $ Identity $ Let (fmap makeLetDeclaration locals) [] - (I.Fix $ Identity $ VarExpr r) + (I.Fix2 $ Identity $ VarExpr $ I.Fix2 $ Identity $ VarRef_ r) in - testCase name $ + it name $ matchReferences (makeImportInfo knownContents imports) (wrapExpr sourceAst) - |> Expect.equals (wrapExpr matchedAst) - in - [ test "identifies unknown references" + `shouldBe` wrapExpr matchedAst + in do + test "identifies unknown references" [] [] [] (VarRef ["A"] (LowercaseIdentifier "a")) (VarRef (Unmatched ["A"]) (LowercaseIdentifier "a")) - , test "matches references from an import" + test "matches references from an import" [] [ "import A" ] [] (VarRef ["A"] (LowercaseIdentifier "a")) (VarRef (MatchedImport True ["A"]) (LowercaseIdentifier "a")) - , test "matches reference to a known value via exposing(..)" + test "matches reference to a known value via exposing(..)" [ ("Html", ["div"]) ] [ "import Html exposing (..)" ] [] (VarRef [] (LowercaseIdentifier "div")) (VarRef (MatchedImport False ["Html"]) (LowercaseIdentifier "div")) - , test "determines references to local variables" + test "determines references to local variables" [] [] [ "a" ] (VarRef [] (LowercaseIdentifier "a")) (VarRef Local (LowercaseIdentifier "a")) - , test "determines unqualified references that are unmatched" + test "determines unqualified references that are unmatched" [] [] [] (VarRef [] (LowercaseIdentifier "a")) (VarRef (UnmatchedUnqualified []) (LowercaseIdentifier "a")) - , test "determines when an unqualified reference might match" + test "determines when an unqualified reference might match" [] [ "import Test exposing (..)" ] [] (VarRef [] (LowercaseIdentifier "describe")) (VarRef (UnmatchedUnqualified [["Test"]]) (LowercaseIdentifier "describe")) - ] - , testGroup "applyReferences" $ + + describe "applyReferences" $ let test :: String @@ -98,59 +95,60 @@ test_tests = -> List String -- locals -> Ref (MatchedNamespace [String]) -> Ref [String] - -> TestTree + -> SpecWith () test name knownContents imports locals sourceAst' matchedAst' = let sourceAst = fmap (fmap $ fmap UppercaseIdentifier) sourceAst' matchedAst = fmap (fmap UppercaseIdentifier) matchedAst' + wrapExpr :: (Ref ns -> I.Fix2 Identity (AST (VariableNamespace ns)) 'ExpressionNK) wrapExpr r = case locals of [] -> -- no locals to define, so just make a var expression - I.Fix $ Identity $ VarExpr r + I.Fix2 $ Identity $ VarExpr $ I.Fix2 $ Identity $ VarRef_ r _ -> -- define the provided locals in a let block - I.Fix $ Identity $ + I.Fix2 $ Identity $ Let (fmap makeLetDeclaration locals) [] - (I.Fix $ Identity $ VarExpr r) + (I.Fix2 $ Identity $ VarExpr $ I.Fix2 $ Identity $ VarRef_ r) in - testCase name $ + it name $ applyReferences (makeImportInfo knownContents imports) (wrapExpr sourceAst) - |> Expect.equals (wrapExpr matchedAst) - in - [ test "local reference is unqualified" + `shouldBe` wrapExpr matchedAst + in do + test "local reference is unqualified" [] [] [] (VarRef Local (LowercaseIdentifier "a")) (VarRef [] (LowercaseIdentifier "a")) - , test "unmatched, unqualified reference is unqualified" + test "unmatched, unqualified reference is unqualified" [] [] [] (VarRef (UnmatchedUnqualified []) (LowercaseIdentifier "a")) (VarRef [] (LowercaseIdentifier "a")) - , test "unmatched, qualified reference is unchanged" + test "unmatched, qualified reference is unchanged" [] [] [] (VarRef (Unmatched ["XYZ", "ABC"]) (LowercaseIdentifier "a")) (VarRef ["XYZ", "ABC"] (LowercaseIdentifier "a")) - , test "qualified, matched import becomes unqualified if explicitly exposed" + test "qualified, matched import becomes unqualified if explicitly exposed" [] [ "import Html exposing (div)" ] [] (VarRef (MatchedImport True ["Html"]) (LowercaseIdentifier "div")) (VarRef [] (LowercaseIdentifier "div")) - , test "qualified, matched import remains qualified if not exposed" + test "qualified, matched import remains qualified if not exposed" [] [ "import Html" ] [] (VarRef (MatchedImport True ["Html"]) (LowercaseIdentifier "div")) (VarRef ["Html"] (LowercaseIdentifier "div")) - , test "qualified, matched import remains qualified if explicitly exposed but hidden by a local" + test "qualified, matched import remains qualified if explicitly exposed but hidden by a local" [] [ "import Html exposing (div)" ] [ "div" ] (VarRef (MatchedImport True ["Html"]) (LowercaseIdentifier "div")) (VarRef ["Html"] (LowercaseIdentifier "div")) - , test "qualified, matched import remains qualified if explicitly exposed but there are exposing(..) with unknown content" + test "qualified, matched import remains qualified if explicitly exposed but there are exposing(..) with unknown content" [] [ "import Html exposing (div)" , "import Html.Extra exposing (..)" @@ -158,7 +156,7 @@ test_tests = [] (VarRef (MatchedImport True ["Html"]) (LowercaseIdentifier "div")) (VarRef ["Html"] (LowercaseIdentifier "div")) - , test "qualified, matched import becomes unqualified if explicitly exposed and there are exposing(..) with known content" + test "qualified, matched import becomes unqualified if explicitly exposed and there are exposing(..) with known content" [ ("Html.Extra", ["notDiv"]) ] [ "import Html exposing (div)" , "import Html.Extra exposing (..)" @@ -166,26 +164,24 @@ test_tests = [] (VarRef (MatchedImport True ["Html"]) (LowercaseIdentifier "div")) (VarRef [] (LowercaseIdentifier "div")) - , test "unqualified, matched import remains unqualified if possible" + test "unqualified, matched import remains unqualified if possible" [] [ "import Html exposing (div)" ] [] (VarRef (MatchedImport False ["Html"]) (LowercaseIdentifier "div")) (VarRef [] (LowercaseIdentifier "div")) - , test "unqualified, matched import becomes qualified if obscured by a local" + test "unqualified, matched import becomes qualified if obscured by a local" [] [ "import Html exposing (div)" ] [ "div" ] (VarRef (MatchedImport False ["Html"]) (LowercaseIdentifier "div")) (VarRef ["Html"] (LowercaseIdentifier "div")) - , test "unqualified, matched import becomes qualified if no longer exposed" + test "unqualified, matched import becomes qualified if no longer exposed" [] [ "import Html" ] [] (VarRef (MatchedImport False ["Html"]) (LowercaseIdentifier "div")) (VarRef ["Html"] (LowercaseIdentifier "div")) - ] - ] makeImportInfo :: [(String, List String)] -> [String] -> ImportInfo [UppercaseIdentifier] @@ -205,18 +201,18 @@ makeKnownContent (moduleName, known) = ) -makeImportMethod :: String -> ([UppercaseIdentifier], ImportMethod) +makeImportMethod :: String -> ([UppercaseIdentifier], ASTNS [UppercaseIdentifier] (I.Fix (ASTNS [UppercaseIdentifier])) 'ImportMethodNK) makeImportMethod importString = case Result.toMaybe $ Parse.parse importString (Parse.Module.import' Elm_0_19) of Nothing -> undefined -- Not handled: fix the test input to parse correctly Just (C _ moduleName, importMethod) -> - (moduleName, importMethod) + (moduleName, I.unFix $ I.fold2 (I.Fix . extract) importMethod) -makeLetDeclaration :: String -> ASTNS Identity ns 'LetDeclarationNK +makeLetDeclaration :: String -> I.Fix2 Identity (ASTNS ns) 'LetDeclarationNK makeLetDeclaration name = - I.Fix $ Identity $ - LetCommonDeclaration $ I.Fix $ Identity $ Definition - (I.Fix $ Identity $ VarPattern $ LowercaseIdentifier name) + I.Fix2 $ Identity $ + LetCommonDeclaration $ I.Fix2 $ Identity $ Definition + (I.Fix2 $ Identity $ VarPattern $ LowercaseIdentifier name) [] [] - (I.Fix $ Identity $ Unit []) + (I.Fix2 $ Identity $ Unit []) diff --git a/elm-format-lib/test/BoxSpec.hs b/elm-format-lib/test/BoxSpec.hs new file mode 100644 index 000000000..4c9dc7d32 --- /dev/null +++ b/elm-format-lib/test/BoxSpec.hs @@ -0,0 +1,99 @@ +module BoxSpec where + +import Elm.Utils ((|>)) + +import Test.Hspec +import qualified Data.Text.Lazy as LazyText +import qualified Data.Text as Text + +import Box +import Data.Text (Text) + + +trim :: String -> String +trim text = + text + |> LazyText.pack + |> LazyText.lines + |> map LazyText.stripEnd + |> LazyText.unlines + |> LazyText.unpack + + +assertLineOutput :: String -> Line -> Expectation +assertLineOutput expected actual = + assertOutput (expected ++ "\n") (line actual) + + +assertOutput :: String -> Box -> Expectation +assertOutput expected actual = + expected `shouldBe` trim (Text.unpack $ render actual) + + +word :: Text -> Box +word = + line . identifier + + +block :: Text -> Box +block text = + stack1 + [ line $ w <> w + , line $ w <> w + ] + where + w = identifier text + + +spec :: Spec +spec = describe "Box" $ do + it "keyword" $ + assertLineOutput "module" $ keyword "module" + it "identifier" $ + assertLineOutput "sqrt" $ identifier "sqrt" + it "punctuation" $ + assertLineOutput "::" $ punc "::" + it "row" $ + assertLineOutput "ab" $ identifier "a" <> identifier "b" + it "space" $ + assertLineOutput "a b" $ identifier "a" <> space <> identifier "b" + + it "stack1" $ + assertOutput "foo\nbar\n" $ + stack1 + [ word "foo" + , word "bar" + ] + it "indent" $ + assertOutput " a\n b\n" $ + indent $ stack1 + [ word "a" + , word "b" + ] + + describe "prefix in front of block with indented lines" $ do + it "when prefix is smaller than a TAB" $ do + prefix (keyword ">>") $ stack1 + [ word "a" + , indent $ word "b" + ] + `shouldOutput` + [ ">>a" + , " b" + ] + + it "when prefix is longer than a TAB" $ do + prefix (keyword ">>>>>") $ stack1 + [ word "a" + , indent $ word "b" + ] + `shouldOutput` + [ ">>>>>a" + , " b" + ] + + +shouldOutput :: Box -> [Text] -> Expectation +shouldOutput box expected = + Box.render box + `shouldBe` Text.unlines expected diff --git a/elm-format-lib/test/BoxTest.hs b/elm-format-lib/test/BoxTest.hs deleted file mode 100644 index 1def5df57..000000000 --- a/elm-format-lib/test/BoxTest.hs +++ /dev/null @@ -1,78 +0,0 @@ -module BoxTest where - -import Elm.Utils ((|>)) - -import Test.Tasty -import Test.Tasty.HUnit -import qualified Data.Text.Lazy as LazyText -import qualified Data.Text as Text - -import Box - - -trim :: String -> String -trim text = - text - |> LazyText.pack - |> LazyText.lines - |> map LazyText.stripEnd - |> LazyText.unlines - |> LazyText.unpack - - -assertLineOutput :: String -> Line -> Assertion -assertLineOutput expected actual = - assertOutput (expected ++ "\n") (line actual) - - -assertOutput :: String -> Box -> Assertion -assertOutput expected actual = - assertEqual expected expected $ - trim $ Text.unpack $ render $ actual - - -word :: String -> Box -word = - line . identifier - - -block :: String -> Box -block text = - stack1 - [ line $ row [ w, w ] - , line $ row [ w, w ] - ] - where - w = identifier text - - -test_tests :: TestTree -test_tests = - testGroup "ElmFormat.Render.BoxTest" - [ testCase "keyword" $ - assertLineOutput "module" $ keyword "module" - , testCase "identifier" $ - assertLineOutput "sqrt" $ identifier "sqrt" - , testCase "punctuation" $ - assertLineOutput "::" $ punc "::" - , testCase "row" $ - assertLineOutput "ab" $ row [ identifier "a", identifier "b" ] - , testCase "space" $ - assertLineOutput "a b" $ row [ identifier "a", space, identifier "b" ] - - , testCase "stack1" $ - assertOutput "foo\nbar\n" $ - stack1 - [ word "foo" - , word "bar" - ] - , testCase "indent" $ - assertOutput " a\n b\n" $ - indent $ stack1 - [ word "a" - , word "b" - ] - , testCase "indent (with leading spaces)" $ - assertOutput " a\n" $ - prefix space $ indent $ line $ identifier "a" - ] diff --git a/elm-format-lib/test/ElmFormat/AST/BinaryOperatorPrecedenceTest.hs b/elm-format-lib/test/ElmFormat/AST/BinaryOperatorPrecedenceSpec.hs similarity index 96% rename from elm-format-lib/test/ElmFormat/AST/BinaryOperatorPrecedenceTest.hs rename to elm-format-lib/test/ElmFormat/AST/BinaryOperatorPrecedenceSpec.hs index d39779bc9..b18cab6ef 100644 --- a/elm-format-lib/test/ElmFormat/AST/BinaryOperatorPrecedenceTest.hs +++ b/elm-format-lib/test/ElmFormat/AST/BinaryOperatorPrecedenceSpec.hs @@ -1,9 +1,8 @@ {-# OPTIONS_GHC -Wno-type-defaults #-} -{-# LANGUAGE FlexibleContexts #-} -module ElmFormat.AST.BinaryOperatorPrecedenceTest where +module ElmFormat.AST.BinaryOperatorPrecedenceSpec where import Prelude hiding (or) -import Test.Tasty.Hspec +import Test.Hspec import qualified ElmFormat.AST.BinaryOperatorPrecedence as BinaryOperatorPrecedence import ElmFormat.AST.BinaryOperatorPrecedence (Tree(..), Precedence(..), Associativity(..)) import ElmFormat.AST.Shared @@ -12,8 +11,8 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -spec_spec :: Spec -spec_spec = +spec :: Spec +spec = describe "ElmFormat.AST.BinaryOperatorPrecedence" $ do it "trivial case: no operators" $ do parse "A" [] diff --git a/elm-format-lib/test/ElmFormat/ImportInfoTest.hs b/elm-format-lib/test/ElmFormat/ImportInfoSpec.hs similarity index 65% rename from elm-format-lib/test/ElmFormat/ImportInfoTest.hs rename to elm-format-lib/test/ElmFormat/ImportInfoSpec.hs index b13fdb72d..b10d880c4 100644 --- a/elm-format-lib/test/ElmFormat/ImportInfoTest.hs +++ b/elm-format-lib/test/ElmFormat/ImportInfoSpec.hs @@ -1,93 +1,102 @@ -module ElmFormat.ImportInfoTest where +module ElmFormat.ImportInfoSpec where import Elm.Utils ((|>)) import AST.V0_16 -import AST.Module (ImportMethod(..), DetailedListing(..)) -import AST.Listing (Listing(..)) -import Test.Tasty -import Test.Tasty.HUnit +import Test.Hspec import qualified Data.Map as Dict import qualified Data.Set as Set import qualified ElmFormat.ImportInfo as ImportInfo import qualified ElmFormat.KnownContents as KnownContents +import qualified Data.Indexed as I -test_tests :: TestTree -test_tests = - testGroup "ElmFormat.ImportInfo" $ + +spec :: Spec +spec = + describe "ElmFormat.ImportInfo" $ let + makeEntry :: + ([String], Maybe String, Listing DetailedListing) + -> ([UppercaseIdentifier], AST p (I.Fix (AST p)) 'ImportMethodNK) makeEntry (a, b, c) = ( fmap UppercaseIdentifier a - , ImportMethod (fmap (C ([], []) . UppercaseIdentifier) b) (C ([], []) c) + , ImportMethod (fmap (C ([], []) . UppercaseIdentifier) b) (C ([], []) $ I.Fix $ ModuleListing c) ) + buildImportInfo :: + List ([String], Maybe String, Listing DetailedListing) + -> ImportInfo.ImportInfo [UppercaseIdentifier] buildImportInfo i = i |> fmap makeEntry |> Dict.fromList |> ImportInfo.fromImports mempty - in - [ testGroup "_directImports" $ + in do + describe "_directImports" $ let assertIncludes = assert "include" True assertExcludes = assert "exclude" False + assert :: + [Char] + -> Bool + -> List String + -> List ([String], Maybe String, Listing DetailedListing) + -> IO () assert what expected name i = let set = buildImportInfo i |> ImportInfo._directImports in - Set.member (fmap UppercaseIdentifier name) set - |> assertEqual ("expected " ++ show set ++ " to " ++ what ++ ": " ++ show name) expected - in - [ testCase "includes Basics" $ + if Set.member (fmap UppercaseIdentifier name) set == expected + then pure () + else expectationFailure ("expected " ++ show set ++ " to " ++ what ++ ": " ++ show name) + in do + it "includes Basics" $ [] |> assertIncludes ["Basics"] - , testCase "includes normal imports" $ + it "includes normal imports" $ [ (["A"], Nothing, ClosedListing) ] |> assertIncludes ["A"] - , testCase "includes normal deep imports" $ + it "includes normal deep imports" $ [ (["A", "Deep"], Nothing, ClosedListing) ] |> assertIncludes ["A", "Deep"] - , testCase "excludes imports with aliases" $ + it "excludes imports with aliases" $ [ (["A"], Just "X", ClosedListing) ] |> assertExcludes ["A"] -- TODO: what if the alias is the same as the import name? - ] - , testGroup "_exposed" - [ testCase "includes exposed values" $ + describe "_exposed" $ do + it "includes exposed values" $ buildImportInfo [(["B"], Nothing, ExplicitListing (DetailedListing (Dict.singleton (LowercaseIdentifier "oldValue") (C ([], []) ())) mempty mempty) False )] |> ImportInfo._exposed |> Dict.lookup (VarName $ LowercaseIdentifier "oldValue") |> assertEqual "contains oldValue" (Just [UppercaseIdentifier "B"]) - , testCase "includes Html.Attributes.style" $ + it "includes Html.Attributes.style" $ buildImportInfo [(["Html", "Attributes"], Nothing, OpenListing (C ([], []) ()))] |> ImportInfo._exposed |> Dict.lookup (VarName $ LowercaseIdentifier "style") |> assertEqual "contains style" (Just [UppercaseIdentifier "Html", UppercaseIdentifier "Attributes"]) - , testCase "includes Basics" $ + it "includes Basics" $ buildImportInfo [] |> ImportInfo._exposed |> Dict.lookup (VarName $ LowercaseIdentifier "identity") |> assertEqual "contains identity" (Just [UppercaseIdentifier "Basics"]) - ] - , testGroup "_exposedTypes" - [ testCase "includes exposed types" $ + describe "_exposedTypes" $ do + it "includes exposed types" $ buildImportInfo [(["B"], Nothing, ExplicitListing (DetailedListing mempty mempty (Dict.singleton (UppercaseIdentifier "OldType") (C ([], []) (C [] ClosedListing)))) False )] |> ImportInfo._exposed |> Dict.lookup (TypeName $ UppercaseIdentifier "OldType") |> assertEqual "contains OldType" (Just [UppercaseIdentifier "B"]) - ] - , testGroup "_unresolvedExposingAll" - [ testCase "includes modules without known content" $ + describe "_unresolvedExposingAll" $ do + it "includes modules without known content" $ buildImportInfo [(["B"], Nothing, OpenListing (C ([], []) ()))] |> ImportInfo._unresolvedExposingAll |> Set.member [UppercaseIdentifier "B"] |> assertEqual "contains B" True - , testCase "does not include moduels with known content" $ + it "does not include moduels with known content" $ [(["B"], Nothing, OpenListing (C ([], []) ()))] |> fmap makeEntry |> Dict.fromList @@ -95,5 +104,8 @@ test_tests = |> ImportInfo._unresolvedExposingAll |> Set.member [UppercaseIdentifier "B"] |> assertEqual "does not contain B" False - ] - ] + + +assertEqual :: (Show a, Eq a) => String -> a -> a -> Expectation +assertEqual description expected actual = + actual `shouldBe` expected diff --git a/elm-format-lib/test/ElmFormat/NormalizeSpec.hs b/elm-format-lib/test/ElmFormat/NormalizeSpec.hs new file mode 100644 index 000000000..f2143566b --- /dev/null +++ b/elm-format-lib/test/ElmFormat/NormalizeSpec.hs @@ -0,0 +1,160 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module ElmFormat.NormalizeSpec where + +import AST.V0_16 + +import qualified Data.Indexed as I +import qualified ElmFormat.Normalize as Normalize +import Test.Hspec +import Control.Monad.Identity (Identity(..)) +import qualified ElmVersion + + +-- type ResultList = +-- Compose List (Either String) + +-- instance Semigroup (ResultList a) where +-- (Compose a) <> (Compose b) = Compose (a <> b) + +-- instance Monad ResultList where +-- -- (Compose es) >>= f = Compose $ es >>= either (pure . Left) (getCompose . f) +-- (Compose []) >>= _ = +-- Compose [] +-- (Compose (Left x : rest)) >>= f = +-- Compose (Left x : getCompose (Compose rest >>= f)) +-- (Compose (Right a : rest)) >>= f = +-- let +-- rest' = getCompose (Compose rest >>= f) +-- in +-- Compose (getCompose (f a) >>= (: rest')) + +-- err :: String -> ASTNS ResultList () nk +-- err = I.Fix . Compose . pure . Left + +-- ok :: ASTNS1 ResultList () nk -> ASTNS ResultList () nk +-- ok = I.Fix . Compose . pure . Right + +-- oks :: List (ASTNS1 ResultList () nk) -> ASTNS ResultList () nk +-- oks = I.Fix . Compose . fmap Right + +lc :: String -> LowercaseIdentifier +lc = LowercaseIdentifier + +c :: List String -> a -> C1 'BeforeTerm a +c comments = + C (BlockComment . pure <$> comments) + + +spec :: Spec +spec = describe "ElmFormat.Normalize" $ do + describe "remove parens within comments in function application" $ + let + ml = FAJoinFirst JoinAll + in do + -- [ testCase "ResultList" $ + -- let + -- var n = VarExpr $ VarRef () $ lc n + -- f = ok $ var "f" + -- in + -- Normalize.deep + -- (ok $ App f + -- [ c ["!"] (oks [var "a", Parens $ C ([BlockComment ["$"]], []) $ oks [var "b", var "c"]]) + -- , c ["@"] (err "x") + -- ] + -- ml ) + -- @=? + -- oks + -- [ App f [ c ["!"] (ok $ var "a"), c ["@"] (err "x")] ml + -- , App f [ c ["!","$"] (oks [var "b", var "c"]), c ["@"] (err "x")] ml + -- ] + -- , testCase "ResultList monad makes sense" $ + -- liftM2 (,) + -- (Compose [Right "a", Left "y"]) + -- (Compose [Left "x", Right "b"]) + -- @=? + -- Compose + -- [ Right $ Compose [ Right "a", Left "x"] + -- , Right $ Compose [ Right "b", Left "x"] + -- ] + + it "List" $ + let + var n = VarExpr $ I.Fix2 [VarRef_ $ VarRef [] $ lc n] + f = I.Fix2 [var "f"] + in do + Normalize.deepMonad ElmVersion.Elm_0_19 + (I.Fix2 [App f + [ c ["!"] (I.Fix2 [var "a", Parens $ C ([BlockComment ["$"]], []) (I.Fix2 [var "b", var "c"])]) + , c ["@"] (I.Fix2 [var "x", var "z"]) + ] + ml ]) + `shouldBe` + I.Fix2 + [ App f [ c ["!"] (I.Fix2 [var "a"]), c ["@"] (I.Fix2 [var "x"])] ml + , App f [ c ["!"] (I.Fix2 [var "a"]), c ["@"] (I.Fix2 [var "z"])] ml + , App f [ c ["!","$"] (I.Fix2 [var "b"]), c ["@"] (I.Fix2 [var "x"])] ml + , App f [ c ["!","$"] (I.Fix2 [var "b"]), c ["@"] (I.Fix2 [var "z"])] ml + , App f [ c ["!","$"] (I.Fix2 [var "c"]), c ["@"] (I.Fix2 [var "x"])] ml + , App f [ c ["!","$"] (I.Fix2 [var "c"]), c ["@"] (I.Fix2 [var "z"])] ml + ] + + -- it "Either" $ + -- let + -- var n = I.Fix2 $ Right $ VarExpr $ I.Fix2 $ Right $ VarRef_ $ VarRef () $ lc n + -- f = var "f" + -- in do + -- Normalize.deepSemigroup + -- (I.Fix2 $ Right $ App f + -- [ c ["!"] (I.Fix2 $ Right $ Parens $ C ([BlockComment ["$"]], []) (var "b")) + -- , c ["@"] (I.Fix2 $ Left ("#$%" :: String)) + -- ] + -- ml) + -- `shouldBe` + -- I.Fix2 (Right $ + -- App f + -- [ c ["!","$"] (var "b") + -- , c ["@"] (I.Fix2 $ Left "#$%") + -- ] + -- ml + -- ) + + -- it "Maybe" $ + -- let + -- var n = I.Fix2 $ Just $ VarExpr $ I.Fix2 $ Just $ VarRef_ $ VarRef () $ lc n + -- f = var "f" + -- in do + -- Normalize.deepAlternative + -- (I.Fix2 $ Just $ App f + -- [ c ["!"] (I.Fix2 $ Just $ Parens $ C ([BlockComment ["$"]], []) (var "b")) + -- , c ["@"] (I.Fix2 Nothing) + -- ] + -- ml) + -- `shouldBe` + -- I.Fix2 (Just $ + -- App f + -- [ c ["!","$"] (var "b") + -- , c ["@"] (I.Fix2 Nothing) + -- ] + -- ml + -- ) + + it "Identity" $ + let + var n = I.Fix2 $ Identity $ VarExpr $ I.Fix2 $ Identity $ VarRef_ $ VarRef [] $ lc n + f = var "f" + in + Normalize.deepMonad ElmVersion.Elm_0_19 + (I.Fix2 $ Identity $ App f + [ c ["!"] (I.Fix2 $ Identity $ Parens $ C ([BlockComment ["$"]], []) (var "b")) + , c ["@"] (var "c") + ] + ml) + `shouldBe` + I.Fix2 (Identity $ + App f + [ c ["!","$"] (var "b") + , c ["@"] (var "c") + ] + ml + ) diff --git a/elm-format-lib/test/ElmFormat/Render/ElmStructureSpec.hs b/elm-format-lib/test/ElmFormat/Render/ElmStructureSpec.hs new file mode 100644 index 000000000..f4ba60fbc --- /dev/null +++ b/elm-format-lib/test/ElmFormat/Render/ElmStructureSpec.hs @@ -0,0 +1,263 @@ +module ElmFormat.Render.ElmStructureSpec where + +import Elm.Utils ((|>)) + +import Test.Hspec +import qualified Data.Text.Lazy as LazyText +import qualified Data.Text as Text + +import AST.V0_16 +import Box +import ElmFormat.Render.ElmStructure +import Data.Text (Text) +import qualified Data.Fix as Fix +import qualified ElmFormat.Render.ElmStructure as ElmStructure +import Data.List.NonEmpty(NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty + + +trim :: String -> String +trim text = + text + |> LazyText.pack + |> LazyText.lines + |> map LazyText.stripEnd + |> LazyText.unlines + |> LazyText.unpack + + +assertOutput :: String -> Elm -> Expectation +assertOutput expected actual = + expected `shouldBe` trim (Text.unpack $ Box.render $ Fix.cata ElmStructure.render actual) + + +word :: Text -> Elm +word = + ElmStructure.identifier + + +a :: Elm ; b :: Elm ; c :: Elm +[a,b,c] = word <$> ["a", "b", "c"] + + +block :: Text -> Elm +block text = + ElmStructure.stack1 $ NonEmpty.fromList + [ word (text<>text) + , word (text<>text) + ] + + +aa :: Elm ; bb :: Elm ; cc :: Elm +[aa,bb,cc] = block <$> ["a", "b", "c"] + + +spec :: Spec +spec = describe "ElmFormat.Render.ElmStructure" $ do + it "application (single line)" $ + assertOutput "a b c\n" $ + application (FAJoinFirst JoinAll) a (b:|[c]) + it "application (multiline)" $ + assertOutput + ( unlines + [ "aa" + , "aa" + , " bb" + , " bb" + , " c" + ] + ) $ + application (FAJoinFirst JoinAll) + aa + ( bb :| [c] ) + + it "group (empty)" $ + assertOutput "()\n" $ + group True "(" "," ")" False [] + it "group (single item, single line)" $ + assertOutput "( foo )\n" $ + group True "(" "," ")" False [ word "foo" ] + it "group (single line)" $ + assertOutput "( foo, bar )\n" $ + group True "(" "," ")" False [ word "foo", word "bar" ] + it "group (single line, no spaces)" $ + assertOutput "(foo, bar)\n" $ + group False "(" "," ")" False [ word "foo", word "bar" ] + it "group (multiline)" $ + assertOutput "( aa\n aa\n, b\n, cc\n cc\n)\n" $ + group True "(" "," ")" False [ aa, b, cc ] + it "group (forced multiline)" $ + assertOutput "( a\n, b\n, c\n)\n" $ + group True "(" "," ")" True [ a, b, c ] + + describe "sectionedGroup" $ do + describe "single item" $ do + it "common" $ do + ElmStructure.sectionedGroup + True "<" ";" ">" False + (a:|[]) + [] Nothing + `shouldOutput` + [ "< a >" ] + + it "force multiline" $ do + ElmStructure.sectionedGroup + True "<" ";" ">" True + (a:|[]) + [] Nothing + `shouldOutput` + [ "< a" + , ">" + ] + + it "no inner spaces" $ do + ElmStructure.sectionedGroup + False "<" ";" ">" False + (a:|[]) + [] Nothing + `shouldOutput` + [ "" ] + + it "item is multiline" $ do + ElmStructure.sectionedGroup + True "<" ";" ">" False + (aa:|[]) + [] Nothing + `shouldOutput` + [ "< aa" + , " aa" + , ">" + ] + + describe "multiple items" $ do + it "common" $ do + ElmStructure.sectionedGroup + True "<" ";" ">" False + (a:|[b, c]) + [] Nothing + `shouldOutput` + [ "< a; b; c >" ] + + it "force multiline" $ do + ElmStructure.sectionedGroup + True "<" ";" ">" True + (a:|[b, c]) + [] Nothing + `shouldOutput` + [ "< a" + , "; b" + , "; c" + , ">" + ] + + it "has a multiline item" $ do + ElmStructure.sectionedGroup + True "<" ";" ">" False + (aa:|[b, cc]) + [] Nothing + `shouldOutput` + [ "< aa" + , " aa" + , "; b" + , "; cc" + , " cc" + , ">" + ] + + it "no inner spaces" $ do + ElmStructure.sectionedGroup + False "<" ";" ">" False + (a:|[b, c]) + [] Nothing + `shouldOutput` + [ "" ] + + it "multiline, no inner spaces" $ do + ElmStructure.sectionedGroup + False "<" ";" ">" False + (aa:|[b, cc]) + [] Nothing + `shouldOutput` + [ "< aa" + , " aa" + , "; b" + , "; cc" + , " cc" + , ">" + ] + + describe "with additional sections" $ do + it "common" $ do + ElmStructure.sectionedGroup + True "<" ";" ">" False + (a:|[b]) + [(word "label", b:|[c])] Nothing + `shouldOutput` + [ "< a" + , "; b" + , "" + , "label" + , "; b" + , "; c" + , ">" + ] + + it "multiline" $ do + ElmStructure.sectionedGroup + True "<" ";" ">" False + (a:|[bb]) + [] (Just $ word "extra") + `shouldOutput` + [ "< a" + , "; bb" + , " bb" + , "" + , "extra" + , ">" + ] + + describe "with extra footer" $ do + -- This fails because of https://github.com/avh4/elm-format/issues/760 + -- it "common" $ do + -- ElmStructure.sectionedGroup + -- True "<" ";" ">" True + -- (a, [b]) + -- [] (Just $ word "extra") + -- `shouldOutput` + -- [ "< a; b extra >" ] + + it "force multiline" $ do + ElmStructure.sectionedGroup + True "<" ";" ">" True + (a:|[b]) + [] (Just $ word "extra") + `shouldOutput` + [ "< a" + , "; b" + , "" + , "extra" + , ">" + ] + + describe "range" $ do + it "common" $ do + ElmStructure.range "[" ".." "]" a b + `shouldOutput` + [ "[a..b]" ] + + it "multiline" $ do + ElmStructure.range "[" ".." "]" aa b + `shouldOutput` + [ "[" + , " aa" + , " aa" + , ".." + , " b" + , "]" + ] + + +shouldOutput :: Elm -> [Text] -> Expectation +shouldOutput elm expected = + Box.render (Fix.cata ElmStructure.render elm) + `shouldBe` Text.unlines expected diff --git a/elm-format-lib/test/ElmFormat/Render/ElmStructureTest.hs b/elm-format-lib/test/ElmFormat/Render/ElmStructureTest.hs deleted file mode 100644 index 283d4e3da..000000000 --- a/elm-format-lib/test/ElmFormat/Render/ElmStructureTest.hs +++ /dev/null @@ -1,91 +0,0 @@ -module ElmFormat.Render.ElmStructureTest where - -import Elm.Utils ((|>)) - -import Test.Tasty -import Test.Tasty.HUnit -import qualified Data.Text.Lazy as LazyText -import qualified Data.Text as Text - -import AST.V0_16 -import Box -import ElmFormat.Render.ElmStructure - - -trim :: String -> String -trim text = - text - |> LazyText.pack - |> LazyText.lines - |> map LazyText.stripEnd - |> LazyText.unlines - |> LazyText.unpack - - -assertLineOutput :: String -> Line -> Assertion -assertLineOutput expected actual = - assertOutput (expected ++ "\n") (line actual) - - -assertOutput :: String -> Box -> Assertion -assertOutput expected actual = - assertEqual expected expected $ - trim $ Text.unpack $ render $ actual - - -word :: String -> Box -word = - line . identifier - - -block :: String -> Box -block text = - stack1 - [ line $ row [ w, w ] - , line $ row [ w, w ] - ] - where - w = identifier text - - -test_tests :: TestTree -test_tests = - testGroup "ElmFormat.Render.ElmStructure" - [ testCase "application (single line)" $ - assertOutput "a b c\n" $ - application (FAJoinFirst JoinAll) (word "a" ) - $ map word [ "b", "c" ] - , testCase "application (multiline)" $ - assertOutput - ( unlines - [ "aa" - , "aa" - , " bb" - , " bb" - , " c" - ] - ) $ - application (FAJoinFirst JoinAll) - ( block "a" ) - [ block "b" - , line $ identifier "c" - ] - , testCase "group (empty)" $ - assertOutput "()\n" $ - group True "(" "," ")" False [] - , testCase "group (single item, single line)" $ - assertOutput "( foo )\n" $ - group True "(" "," ")" False [ word "foo" ] - , testCase "group (single line)" $ - assertOutput "( foo, bar )\n" $ - group True "(" "," ")" False [ word "foo", word "bar" ] - , testCase "group (single line, no spaces)" $ - assertOutput "(foo, bar)\n" $ - group False "(" "," ")" False [ word "foo", word "bar" ] - , testCase "group (multiline)" $ - assertOutput "( aa\n aa\n, b\n, cc\n cc\n)\n" $ - group True "(" "," ")" False [ block "a", word "b", block "c" ] - , testCase "group (forced multiline)" $ - assertOutput "( a\n, b\n, c\n)\n" $ - group True "(" "," ")" True [ word "a", word "b", word "c" ] - ] diff --git a/elm-format-lib/test/IndentSpec.hs b/elm-format-lib/test/IndentSpec.hs new file mode 100644 index 000000000..0dd1761d5 --- /dev/null +++ b/elm-format-lib/test/IndentSpec.hs @@ -0,0 +1,57 @@ +module IndentSpec where + +import Test.Hspec +import Test.Hspec.QuickCheck +import qualified Indent + + +spec :: Spec +spec = describe "Indent" $ + let + check a b expected = + it (show a <> " <> " <> show b <> " == " <> show expected) $ + check' a b expected + + check' a b expected = + Indent.spaces a <> Indent.spaces b + `shouldBe` Indent.spaces expected + in do + prop "full tabs should combine" $ + \a b -> check' (4*a) (4*b) (4*(a+b)) + + prop "zero is left identity" $ + \x -> check' 0 x x + prop "zero is right identity" $ + \x -> check' x 0 x + + describe "when left is less than one tab" $ do + check 1 4 4 + check 2 4 4 + check 3 4 4 + check 1 8 8 + + prop "when left is full tab, always add" $ + \a b -> check' (4*a) b (4*a + b) + + describe "when the sum does not exceed the next tabstop" $ do + check 1 1 2 + check 1 2 3 + check 1 3 4 + + check 2 1 3 + check 2 2 4 + + check 6 1 7 + check 6 2 8 + check 5 3 8 + + check 3 3 6 -- s s s s s s => 6 + check 6 4 8 -- tab s s tab => 8 + check 2 7 7 -- s s tab s s s => 7 + check 6 7 11 -- tab s s tab s s s => 11 + + prop "associativity" $ + \a b c -> + (Indent.spaces a <> Indent.spaces b) <> Indent.spaces c + `shouldBe` + Indent.spaces a <> (Indent.spaces b <> Indent.spaces c) diff --git a/elm-format-lib/test/Parse/ExpressionSpec.hs b/elm-format-lib/test/Parse/ExpressionSpec.hs new file mode 100644 index 000000000..c2e39fb10 --- /dev/null +++ b/elm-format-lib/test/Parse/ExpressionSpec.hs @@ -0,0 +1,291 @@ +module Parse.ExpressionSpec where + +import Test.Hspec hiding (example) + +import Parse.Expression +import AST.V0_16 +import AST.Structure +import qualified Box +import qualified Data.Bimap as Bimap +import Data.Coapplicative +import qualified Data.Indexed as I +import qualified Data.Text as Text +import Parse.ParsecAdapter (string) +import ElmFormat.ImportInfo (ImportInfo(..)) +import ElmFormat.Render.Box (formatExpression, syntaxParens, SyntaxContext (SyntaxSeparated)) +import ElmVersion +import Parse.TestHelpers +import Reporting.Annotation (Located) +import Data.Word (Word16) +import GHC.Int (Int64) +import qualified ElmFormat.Render.ElmStructure as ElmStructure +import qualified Data.Fix as Fix + + +pending :: I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK +pending = at 0 0 0 0 $ Unit [] + + +example :: String -> String -> I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ExpressionNK -> SpecWith () +example name input expected = + it name $ + assertParse (expr Elm_0_19) input expected + + +importInfo :: Ord ns => ImportInfo ns +importInfo = + ImportInfo mempty Bimap.empty mempty mempty mempty + + +example' :: String -> String -> String -> SpecWith () +example' name input expected = + it name $ + assertParse (fmap (Text.unpack . Box.render . Fix.cata ElmStructure.render . syntaxParens SyntaxSeparated . formatExpression Elm_0_19 importInfo . I.fold2 (I.Fix . extract)) (expr Elm_0_19)) input expected + + +commentedIntExpr :: (Word16, Word16, Word16, Word16) -> String -> String -> Int64 -> Commented ([Comment], [Comment]) (I.Fix2 Located (ASTNS ns) 'ExpressionNK) +commentedIntExpr (a,b,c,d) preComment postComment i = + C ([BlockComment [preComment]], [BlockComment [postComment]]) (at a b c d $ Literal $ IntNum i DecimalInt) + +commentedIntExpr' :: (Word16, Word16, Word16, Word16) -> String -> Int64 -> Commented ([Comment], [a]) (I.Fix2 Located (ASTNS ns) 'ExpressionNK) +commentedIntExpr' (a,b,c,d) preComment i = + C ([BlockComment [preComment]], []) (at a b c d $ Literal $ IntNum i DecimalInt) + + +commentedIntExpr'' :: (Word16, Word16, Word16, Word16) -> String -> Int64 -> Commented [Comment] (I.Fix2 Located (ASTNS ns) 'ExpressionNK) +commentedIntExpr'' (a,b,c,d) preComment i = + C [BlockComment [preComment]] $ at a b c d $ Literal $ IntNum i DecimalInt + + +intExpr :: (Word16, Word16, Word16, Word16) -> Int64 -> I.Fix2 Located (ASTNS ns) 'ExpressionNK +intExpr (a,b,c,d) i = at a b c d $ Literal $ IntNum i DecimalInt + +intExpr' :: (Word16, Word16, Word16, Word16) -> Int64 -> Commented ([a1], [a2]) (I.Fix2 Located (ASTNS ns) 'ExpressionNK) +intExpr' (a,b,c,d) i = + C ([], []) (at a b c d $ Literal $ IntNum i DecimalInt) + +intExpr'' :: (Word16, Word16, Word16, Word16) -> Int64 -> Commented [a] (I.Fix2 Located (ASTNS ns) 'ExpressionNK) +intExpr'' (a,b,c,d) i = + C [] $ at a b c d $ Literal $ IntNum i DecimalInt + + +spec :: Spec +spec = describe "Parse.Expression" $ do + describe "Unit" $ do + example "" "()" $ at 1 1 1 3 $ Unit [] + example "whitespace" "( )" $ at 1 1 1 4 $ Unit [] + example "comments" "({-A-})" $ at 1 1 1 8 $ Unit [BlockComment ["A"]] + example "newlines" "(\n )" $ at 1 1 2 3 $ Unit [] + + describe "Literal" $ do + example "" "1" $ at 1 1 1 2 (Literal (IntNum 1 DecimalInt)) + + describe "Boolean" $ do + example "True" "True" $ at 1 1 1 5 $ Literal $ Boolean True + example "False" "False" $ at 1 1 1 6 $ Literal $ Boolean False + + describe "variable" $ do + example "lowercase" "foo" $ at 1 1 1 4 $ VarExpr $ at 1 1 1 4 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "foo" + example "uppercase" "Bar" $ at 1 1 1 4 $ VarExpr $ at 1 1 1 4 $ VarRef_ $ TagRef [] $ UppercaseIdentifier "Bar" + example "qualified" "Bar.Baz.foo" $ at 1 1 1 12 $ VarExpr $ at 1 1 1 12 $ VarRef_ $ VarRef [UppercaseIdentifier "Bar", UppercaseIdentifier "Baz"] $ LowercaseIdentifier "foo" + + describe "symbolic operator" $ do + example "" "(+)" $ at 1 1 1 4 $ VarExpr $ at 1 2 1 3 $ VarRef_ $ OpRef (SymbolIdentifier "+") + it "does not allow whitespace" $ + assertParseFailure (expr Elm_0_19) "( + )" + it "doew not allow comments" $ + assertParseFailure (expr Elm_0_19) "({-A-}+{-B-})" + + describe "function application" $ do + example "" "f 7 8" $ at 1 1 1 6 $ App (at 1 1 1 2 $ VarExpr $ at 1 1 1 2 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "f") [intExpr'' (1,3,1,4) 7, intExpr'' (1,5,1,6) 8] (FAJoinFirst JoinAll) + example "argument starts with minus" "f -9 -x" $ at 1 1 1 8 $ App (at 1 1 1 2 $ VarExpr $ at 1 1 1 2 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "f") [intExpr'' (1,3,1,5) (-9), C [] $ at 1 6 1 8 $ Unary Negative $ at 1 7 1 8 $ VarExpr $ at 1 7 1 8 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "x"] (FAJoinFirst JoinAll) + example "comments" "f{-A-}7{-B-}8" $ at 1 1 1 14 $ App (at 1 1 1 2 $ VarExpr $ at 1 1 1 2 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "f") [commentedIntExpr'' (1,7,1,8) "A" 7, commentedIntExpr'' (1,13,1,14) "B" 8] (FAJoinFirst JoinAll) + example "newlines (1)" "f 7\n 8" $ at 1 1 2 3 $ App (at 1 1 1 2 $ VarExpr $ at 1 1 1 2 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "f") [intExpr'' (1,3,1,4) 7, intExpr'' (2,2,2,3) 8] (FAJoinFirst SplitAll) + example "newlines (2)" "f\n 7\n 8" $ at 1 1 3 3 $ App (at 1 1 1 2 $ VarExpr $ at 1 1 1 2 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "f") [intExpr'' (2,2,2,3) 7, intExpr'' (3,2,3,3) 8] FASplitFirst + example "newlines and comments" "f\n {-A-}7\n {-B-}8" $ at 1 1 3 8 $ App (at 1 1 1 2 $ VarExpr $ at 1 1 1 2 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "f") [commentedIntExpr'' (2,7,2,8) "A" 7, commentedIntExpr'' (3,7,3,8) "B" 8] FASplitFirst + + describe "unary operators" $ do + describe "negative" $ do + example "" "-True" $ at 1 1 1 6 $ Unary Negative $ at 1 2 1 6 $ Literal $ Boolean True + it "must not have whitespace" $ + assertParseFailure (expr Elm_0_19) "- True" + it "must not have comment" $ + assertParseFailure (expr Elm_0_19) "-{- -}True" + it "does not apply to '-'" $ + assertParseFailure (expr Elm_0_19) "--True" + it "does not apply to '.'" $ + assertParseFailure (expr Elm_0_19) "-.foo" + + describe "binary operators" $ do + example "" "7+8<<>>9" $ at 1 1 1 9 $ Binops (intExpr (1,1,1,2) 7) [BinopsClause [] (at 1 2 1 3 $ VarRef_ $ OpRef $ SymbolIdentifier "+") [] (intExpr (1,3,1,4) 8), BinopsClause [] (at 1 4 1 8 $ VarRef_ $ OpRef $ SymbolIdentifier "<<>>") [] (intExpr (1,8,1,9) 9)] False + example "minus with no whitespace" "9-1" $ at 1 1 1 4 $ Binops (intExpr (1,1,1,2) 9) [BinopsClause [] (at 1 2 1 3 $ VarRef_ $ OpRef $ SymbolIdentifier "-") [] (intExpr (1,3,1,4) 1)] False + example "backticks" "7`plus`8`shift`9" $ at 1 1 1 17 $ Binops (intExpr (1,1,1,2) 7) [BinopsClause [] (at 1 2 1 8 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "plus") [] (intExpr (1,8,1,9) 8), BinopsClause [] (at 1 9 1 16 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "shift") [] (intExpr (1,16,1,17) 9)] False + example "whitespace" "7 + 8 <<>> 9" $ at 1 1 1 13 $ Binops (intExpr (1,1,1,2) 7) [BinopsClause [] (at 1 3 1 4 $ VarRef_ $ OpRef $ SymbolIdentifier "+") [] (intExpr (1,5,1,6) 8), BinopsClause [] (at 1 7 1 11 $ VarRef_ $ OpRef $ SymbolIdentifier "<<>>") [] (intExpr (1,12,1,13) 9)] False + example "comments" "7{-A-}+{-B-}8{-C-}<<>>{-D-}9" $ at 1 1 1 29 $ Binops (intExpr (1,1,1,2) 7) [BinopsClause [BlockComment ["A"]] (at 1 7 1 8 $ VarRef_ $ OpRef $ SymbolIdentifier "+") [BlockComment ["B"]] (intExpr (1,13,1,14) 8), BinopsClause [BlockComment ["C"]] (at 1 19 1 23 $ VarRef_ $ OpRef $ SymbolIdentifier "<<>>") [BlockComment ["D"]] (intExpr (1,28,1,29) 9)] False + example "newlines" "7\n +\n 8\n <<>>\n 9" $ at 1 1 5 3 $ Binops (intExpr (1,1,1,2) 7) [BinopsClause [] (at 2 2 2 3 $ VarRef_ $ OpRef $ SymbolIdentifier "+") [] (intExpr (3,2,3,3) 8), BinopsClause [] (at 4 2 4 6 $ VarRef_ $ OpRef $ SymbolIdentifier "<<>>") [] (intExpr (5,2,5,3) 9)] True + + describe "parentheses" $ do + example "" "(1)" $ at 1 1 1 4 $ Parens $ intExpr' (1,2,1,3) 1 + example "whitespace" "( 1 )" $ at 1 1 1 6 $ Parens $ intExpr' (1,3,1,4) 1 + example "comments" "({-A-}1{-B-})" $ at 1 1 1 14 $ Parens $ commentedIntExpr (1,7,1,8) "A" "B" 1 + example "newlines" "(\n 1\n )" $ at 1 1 3 3 $ Parens $ intExpr' (2,2,2,3) 1 + + describe "empty list" $ do + example' "empty" "[]" "[]\n" + example' "whitespace" "[ ]" "[]\n" + example' "comments" "[{-A-}]" "[{- A -}]\n" + example' "newlines" "[\n ]" "[]\n" + + describe "List" $ do + example' "" "[1,2,3]" "[ 1, 2, 3 ]\n" + example' "single element" "[1]" "[ 1 ]\n" + example' "whitespace" "[ 1 , 2 , 3 ]" "[ 1, 2, 3 ]\n" + example' "comments" + "[{-A-}1{-B-},{-C-}2{-D-},{-E-}3{-F-}]" + "[ {- A -} 1\n\ + \\n\ + \{- B -}\n\ + \, {- C -} 2\n\ + \\n\ + \{- D -}\n\ + \, {- E -} 3\n\ + \\n\ + \{- F -}\n\ + \]\n" + example' "sections with multiple items" + "[{-A-}1{-B-},{-C-}2,{-D-}3]" + "[ {- A -} 1\n\ + \\n\ + \{- B -}\n\ + \, {- C -} 2\n\ + \, {- D -} 3\n\ + \]\n" + example' "newlines" + "[\n 1\n ,\n 2\n ,\n 3\n ]" + "[ 1\n, 2\n, 3\n]\n" + + describe "Range" $ do + example "" "[7..9]" $ at 1 1 1 7 $ Range (intExpr' (1,2,1,3) 7) (intExpr' (1,5,1,6) 9) + example "whitespace" "[ 7 .. 9 ]" $ at 1 1 1 11 $ Range (intExpr' (1,3,1,4) 7) (intExpr' (1,8,1,9) 9) + example "comments" "[{-A-}7{-B-}..{-C-}9{-D-}]" $ at 1 1 1 27 $ Range (commentedIntExpr (1,7,1,8) "A" "B" 7) (commentedIntExpr (1,20,1,21) "C" "D" 9) + example "newlines" "[\n 7\n ..\n 9\n ]" $ at 1 1 5 3 $ Range (intExpr' (2,2,2,3) 7) (intExpr' (4,2,4,3) 9) + + describe "Tuple" $ do + example "" "(1,2)" $ at 1 1 1 6 $ Tuple [intExpr' (1,2,1,3) 1, intExpr' (1,4,1,5) 2] False + example "whitespace" "( 1 , 2 )" $ at 1 1 1 10 $ Tuple [intExpr' (1,3,1,4) 1, intExpr' (1,7,1,8) 2] False + example "comments" "({-A-}1{-B-},{-C-}2{-D-})" $ at 1 1 1 26 $ Tuple [commentedIntExpr (1,7,1,8) "A" "B" 1, commentedIntExpr (1,19,1,20) "C" "D" 2] False + example "newlines" "(\n 1\n ,\n 2\n )" $ at 1 1 5 3 $ Tuple [intExpr' (2,2,2,3) 1, intExpr' (4,2,4,3) 2] True + + describe "tuple constructor" $ do + example "" "(,,)" $ at 1 1 1 5 $ TupleFunction 3 + it "does not allow whitespace (1)" $ assertParseFailure (expr Elm_0_19) "( ,,)" + it "does not allow whitespace (2)" $ assertParseFailure (expr Elm_0_19) "(, ,)" + it "does not allow whitespace (3)" $ assertParseFailure (expr Elm_0_19) "(,, )" + it "does not allow comments (1)" $ assertParseFailure (expr Elm_0_19) "({-A-},,)" + it "does not allow comments (2)" $ assertParseFailure (expr Elm_0_19) "(,{-A-},)" + it "does not allow comments (3)" $ assertParseFailure (expr Elm_0_19) "(,,{-A-})" + + describe "Record" $ do + describe "empty" $ do + example' "" "{}" "{}\n" + example' "whitespace" "{ }" "{}\n" + example' "comments" "{{-A-}}" "{{- A -}}\n" + + example' "" + "{x=7,y=8}" + "{ x = 7, y = 8 }\n" + example' "single field" + "{x=7}" + "{ x = 7 }\n" + example' "whitespace" + "{ x = 7 , y = 8 }" + "{ x = 7, y = 8 }\n" + example' "comments" + "{{-A-}x{-B-}={-C-}7{-D-},{-E-}y{-F-}={-G-}8{-H-}}" + "{ {- A -} x {- B -} = {- C -} 7\n\n{- D -}\n, {- E -} y {- F -} = {- G -} 8\n\n{- H -}\n}\n" + example' "single field with comments" + "{{-A-}x{-B-}={-C-}7{-D-}}" + "{ {- A -} x {- B -} = {- C -} 7\n\n{- D -}\n}\n" + example' "newlines" + "{\n x\n =\n 7\n ,\n y\n =\n 8\n }" + "{ x =\n 7\n, y =\n 8\n}\n" + + describe "Record update" $ do + example' "" + "{a|x=7,y=8}" + "{ a | x = 7, y = 8 }\n" + example' "single field" + "{a|x=7}" + "{ a | x = 7 }\n" + example' "whitespace" + "{ a | x = 7 , y = 8 }" + "{ a | x = 7, y = 8 }\n" + example' "comments" + "{{-A-}a{-B-}|{-C-}x{-D-}={-E-}7{-F-},{-G-}y{-H-}={-I-}8{-J-}}" + "{ {- A -} a {- B -}\n | {- C -} x {- D -} = {- E -} 7\n\n {- F -}\n , {- G -} y {- H -} = {- I -} 8\n\n {- J -}\n}\n" + example' "comments + multiline" + "{{-A-}a{-B-}|\n{-C-}x{-D-}={-E-}7{-F-},{-G-}y{-H-}={-I-}8{-J-}}" + "{ {- A -} a {- B -}\n | {- C -} x {- D -} = {- E -} 7\n\n {- F -}\n , {- G -} y {- H -} = {- I -} 8\n\n {- J -}\n}\n" + example' "newlines" + "{\n a\n |\n x\n =\n 7\n ,\n y\n =\n 8\n }" + "{ a\n | x =\n 7\n , y =\n 8\n}\n" + it "only allows simple base" $ + assertParseFailure (expr Elm_0_19) "{9|x=7}" + it "only allows simple base" $ + assertParseFailure (expr Elm_0_19) "{{}|x=7}" + example' "no fields (elm-compiler does not allow this)" + "{a|}" + "{ a | }\n" + + describe "record access" $ do + example "" "x.f1" $ at 1 1 1 5 (Access (at 1 1 1 2 $ VarExpr $ at 1 1 1 2 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "x") (LowercaseIdentifier "f1")) + example "nested" "x.f1.f2" $ at 1 1 1 8 (Access (at 1 1 1 5 (Access (at 1 1 1 2 $ VarExpr $ at 1 1 1 2 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "x") (LowercaseIdentifier "f1"))) (LowercaseIdentifier "f2")) + it "does not allow symbolic field names" $ + assertParseFailure (expr Elm_0_19) "x.+" + it "does not allow symbolic field names" $ + assertParseFailure (expr Elm_0_19) "x.(+)" + + describe "record access fuction" $ do + example "" ".f1" $ at 1 1 1 4 $ AccessFunction (LowercaseIdentifier "f1") + + describe "lambda" $ do + example "" "\\x y->9" $ at 1 1 1 8 $ Lambda [C [] ( at 1 2 1 3 $ VarPattern $ LowercaseIdentifier "x"), C [] ( at 1 4 1 5 $ VarPattern $ LowercaseIdentifier "y")] [] (intExpr (1,7,1,8) 9) False + example "single parameter" "\\x->9" $ at 1 1 1 6 $ Lambda [C [] ( at 1 2 1 3 $ VarPattern $ LowercaseIdentifier "x")] [] (intExpr (1,5,1,6) 9) False + example "whitespace" "\\ x y -> 9" $ at 1 1 1 11 $ Lambda [C [] ( at 1 3 1 4 $ VarPattern $ LowercaseIdentifier "x"), C [] ( at 1 5 1 6 $ VarPattern $ LowercaseIdentifier "y")] [] (intExpr (1,10,1,11) 9) False + example "comments" "\\{-A-}x{-B-}y{-C-}->{-D-}9" $ at 1 1 1 27 $ Lambda [C [BlockComment ["A"]] ( at 1 7 1 8 $ VarPattern $ LowercaseIdentifier "x"), C [BlockComment ["B"]] ( at 1 13 1 14 $ VarPattern $ LowercaseIdentifier "y")] [BlockComment ["C"], BlockComment ["D"]] (intExpr (1,26,1,27) 9) False + example "newlines" "\\\n x\n y\n ->\n 9" $ at 1 1 5 3 $ Lambda [C [] ( at 2 2 2 3 $ VarPattern $ LowercaseIdentifier "x"), C [] ( at 3 2 3 3 $ VarPattern $ LowercaseIdentifier "y")] [] (intExpr (5,2,5,3) 9) True + it "arrow must not contain whitespace" $ + assertParseFailure (expr Elm_0_19) "\\x y - > 9" + + describe "if statement" $ do + example "" "if x then y else z" $ at 1 1 1 19 (If (IfClause (C ([], []) (at 1 4 1 5 $ VarExpr $ at 1 4 1 5 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "x")) (C ([], []) (at 1 11 1 12 $ VarExpr $ at 1 11 1 12 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "y"))) [] (C [] (at 1 18 1 19 $ VarExpr $ at 1 18 1 19 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "z"))) + example "comments" "if{-A-}x{-B-}then{-C-}y{-D-}else{-E-}if{-F-}x_{-G-}then{-H-}y_{-I-}else{-J-}z" $ at 1 1 1 78 (If (IfClause (C ([BlockComment ["A"]], [BlockComment ["B"]]) (at 1 8 1 9 $ VarExpr $ at 1 8 1 9 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "x")) (C ([BlockComment ["C"]], [BlockComment ["D"]]) (at 1 23 1 24 $ VarExpr $ at 1 23 1 24 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "y"))) [C [BlockComment ["E"]] (IfClause (C ([BlockComment ["F"]], [BlockComment ["G"]]) (at 1 45 1 47 $ VarExpr $ at 1 45 1 47 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "x_")) (C ([BlockComment ["H"]], [BlockComment ["I"]]) (at 1 61 1 63 $ VarExpr $ at 1 61 1 63 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "y_")))] (C [BlockComment ["J"]] (at 1 77 1 78 $ VarExpr $ at 1 77 1 78 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "z"))) + example "else if" "if x1 then y1 else if x2 then y2 else if x3 then y3 else z" $ at 1 1 1 59 (If (IfClause (C ([], []) (at 1 4 1 6 $ VarExpr $ at 1 4 1 6 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "x1")) (C ([], []) (at 1 12 1 14 $ VarExpr $ at 1 12 1 14 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "y1"))) [C [] (IfClause (C ([], []) (at 1 23 1 25 $ VarExpr $ at 1 23 1 25 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "x2")) (C ([], []) (at 1 31 1 33 $ VarExpr $ at 1 31 1 33 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "y2"))),C [] (IfClause (C ([], []) (at 1 42 1 44 $ VarExpr $ at 1 42 1 44 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "x3")) (C ([], []) (at 1 50 1 52 $ VarExpr $ at 1 50 1 52 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "y3")))] (C [] (at 1 58 1 59 $ VarExpr $ at 1 58 1 59 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "z"))) + example "newlines" "if\n x\n then\n y\n else\n z" $ at 1 1 6 3 (If (IfClause (C ([], []) (at 2 2 2 3 $ VarExpr $ at 2 2 2 3 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "x")) (C ([], []) (at 4 2 4 3 $ VarExpr $ at 4 2 4 3 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "y"))) [] (C [] $ at 6 2 6 3 $ VarExpr $ at 6 2 6 3 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "z")) + + describe "let statement" $ do + example "" "let a=b in z" $ at 1 1 1 13 (Let [at 1 5 1 8 $ LetCommonDeclaration $ at 1 5 1 8 $ Definition (at 1 5 1 6 (VarPattern (LowercaseIdentifier "a"))) [] [] (at 1 7 1 8 $ VarExpr $ at 1 7 1 8 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "b")] [] (at 1 12 1 13 $ VarExpr $ at 1 12 1 13 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "z")) + example "multiple declarations" "let a=b\n c=d\nin z" $ at 1 1 3 5 (Let [at 1 5 1 8 $ LetCommonDeclaration $ at 1 5 1 8 $ Definition (at 1 5 1 6 (VarPattern (LowercaseIdentifier "a"))) [] [] (at 1 7 1 8 $ VarExpr $ at 1 7 1 8 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "b"),at 2 5 2 8 $ LetCommonDeclaration $ at 2 5 2 8 $ Definition (at 2 5 2 6 (VarPattern (LowercaseIdentifier "c"))) [] [] (at 2 7 2 8 $ VarExpr $ at 2 7 2 8 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "d")] [] (at 3 4 3 5 $ VarExpr $ at 3 4 3 5 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "z")) + example "multiple declarations" "let\n a=b\n c=d\nin z" $ at 1 1 4 5 (Let [at 2 2 2 5 $ LetCommonDeclaration $ at 2 2 2 5 $ Definition (at 2 2 2 3 (VarPattern (LowercaseIdentifier "a"))) [] [] (at 2 4 2 5 $ VarExpr $ at 2 4 2 5 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "b"),at 3 2 3 5 $ LetCommonDeclaration $ at 3 2 3 5 $ Definition (at 3 2 3 3 (VarPattern (LowercaseIdentifier "c"))) [] [] (at 3 4 3 5 $ VarExpr $ at 3 4 3 5 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "d")] [] (at 4 4 4 5 $ VarExpr $ at 4 4 4 5 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "z")) + example "whitespace" "let a = b in z" $ at 1 1 1 15 (Let [at 1 5 1 10 $ LetCommonDeclaration $ at 1 5 1 10 $ Definition (at 1 5 1 6 (VarPattern (LowercaseIdentifier "a"))) [] [] (at 1 9 1 10 $ VarExpr $ at 1 9 1 10 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "b")] [] (at 1 14 1 15 $ VarExpr $ at 1 14 1 15 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "z")) + example "comments" "let{-A-}a{-B-}={-C-}b{-D-}in{-E-}z" $ at 1 1 1 35 (Let [at 1 4 1 9 $ LetComment (BlockComment ["A"]),at 1 9 1 22 $ LetCommonDeclaration $ at 1 9 1 22 $ Definition (at 1 9 1 10 (VarPattern (LowercaseIdentifier "a"))) [] [BlockComment ["B"],BlockComment ["C"]] (at 1 21 1 22 $ VarExpr $ at 1 21 1 22 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "b"),at 1 22 1 27 $ LetComment (BlockComment ["D"])] [BlockComment ["E"]] (at 1 34 1 35 $ VarExpr $ at 1 34 1 35 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "z")) + example "newlines" "let\n a\n =\n b\nin\n z" $ at 1 1 6 3 (Let [at 2 2 4 3 $ LetCommonDeclaration $ at 2 2 4 3 $ Definition (at 2 2 2 3 (VarPattern (LowercaseIdentifier "a"))) [] [] (at 4 2 4 3 $ VarExpr $ at 4 2 4 3 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "b")] [] (at 6 2 6 3 $ VarExpr $ at 6 2 6 3 $ VarRef_ $ VarRef [] $ LowercaseIdentifier "z")) + it "must have at least one definition" $ + assertParseFailure (expr Elm_0_19) "let in z" + describe "declarations must start at the same column" $ do + it "(1)" $ assertParseFailure (expr Elm_0_19) "let a=b\n c=d\nin z" + it "(2)" $ assertParseFailure (expr Elm_0_19) "let a=b\n c=d\nin z" + it "(3)" $ assertParseFailure (expr Elm_0_19) "let a=b\n c=d\nin z" + + describe "case statement" $ do + example "" "case 9 of\n 1->10\n _->20" $ at 1 1 3 7 (Case (C ([], []) (at 1 6 1 7 (Literal (IntNum 9 DecimalInt))),False) [at 2 2 2 7 $ CaseBranch [] [] [] (at 2 2 2 3 $ LiteralPattern $ IntNum 1 DecimalInt) (at 2 5 2 7 $ Literal $ IntNum 10 DecimalInt), at 2 7 3 7 $ CaseBranch [] [] [] (at 3 2 3 3 Anything) (at 3 5 3 7 $ Literal $ IntNum 20 DecimalInt)]) + example "no newline after 'of'" "case 9 of 1->10\n _->20" $ at 1 1 2 16 (Case (C ([], []) (at 1 6 1 7 (Literal (IntNum 9 DecimalInt))),False) [at 1 11 1 16 $ CaseBranch [] [] [] (at 1 11 1 12 $ LiteralPattern $ IntNum 1 DecimalInt) (at 1 14 1 16 $ Literal $ IntNum 10 DecimalInt), at 1 16 2 16 $ CaseBranch [] [] [] (at 2 11 2 12 Anything) (at 2 14 2 16 $ Literal $ IntNum 20 DecimalInt)]) + example "whitespace" "case 9 of\n 1 -> 10\n _ -> 20" $ at 1 1 3 9 (Case (C ([], []) (at 1 6 1 7 (Literal (IntNum 9 DecimalInt))),False) [at 2 2 2 9 $ CaseBranch [] [] [] (at 2 2 2 3 $ LiteralPattern $ IntNum 1 DecimalInt) (at 2 7 2 9 $ Literal $ IntNum 10 DecimalInt), at 2 9 3 9 $ CaseBranch [] [] [] (at 3 2 3 3 Anything) (at 3 7 3 9 $ Literal $ IntNum 20 DecimalInt)]) + example "comments" "case{-A-}9{-B-}of{-C-}\n{-D-}1{-E-}->{-F-}10{-G-}\n{-H-}_{-I-}->{-J-}20" $ at 1 1 3 21 (Case (C ([BlockComment ["A"]], [BlockComment ["B"]]) (at 1 10 1 11 (Literal (IntNum 9 DecimalInt))),False) [at 2 6 2 21 $ CaseBranch [BlockComment ["C"],BlockComment ["D"]] [BlockComment ["E"]] [BlockComment ["F"]] (at 2 6 2 7 $ LiteralPattern $ IntNum 1 DecimalInt) (at 2 19 2 21 $ Literal $ IntNum 10 DecimalInt), at 2 21 3 21 $ CaseBranch [BlockComment ["G"],BlockComment ["H"]] [BlockComment ["I"]] [BlockComment ["J"]] (at 3 6 3 7 Anything) (at 3 19 3 21 $ Literal $ IntNum 20 DecimalInt)]) + example "newlines" "case\n 9\n of\n 1\n ->\n 10\n _\n ->\n 20" $ at 1 1 9 4 (Case (C ([], []) (at 2 2 2 3 (Literal (IntNum 9 DecimalInt))),True) [at 4 2 6 4 $ CaseBranch [] [] [] (at 4 2 4 3 $ LiteralPattern $ IntNum 1 DecimalInt) (at 6 2 6 4 $ Literal $ IntNum 10 DecimalInt), at 6 4 9 4 $ CaseBranch [] [] [] (at 7 2 7 3 Anything) (at 9 2 9 4 $ Literal $ IntNum 20 DecimalInt)]) + it "should not consume trailing whitespace" $ + assertParse (expr Elm_0_19>> string "\nX") "case 9 of\n 1->10\n _->20\nX" "\nX" + describe "clauses must start at the same column" $ do + it "(1)" $ assertParseFailure (expr Elm_0_19) "case 9 of\n 1->10\n_->20" + it "(2)" $ assertParseFailure (expr Elm_0_19) "case 9 of\n 1->10\n _->20" + it "(3)" $ assertParseFailure (expr Elm_0_19) "case 9 of\n 1->10\n _->20" diff --git a/elm-format-lib/test/Parse/ExpressionTest.hs b/elm-format-lib/test/Parse/ExpressionTest.hs deleted file mode 100644 index 74129a11b..000000000 --- a/elm-format-lib/test/Parse/ExpressionTest.hs +++ /dev/null @@ -1,309 +0,0 @@ -{-# LANGUAGE DataKinds #-} -module Parse.ExpressionTest where - -import Test.Tasty -import Test.Tasty.HUnit - -import Parse.Expression -import AST.V0_16 -import AST.Structure -import qualified Box -import qualified Data.Bimap as Bimap -import Data.Coapplicative -import Data.Functor.Identity -import qualified Data.Indexed as I -import qualified Data.Text as Text -import Parse.ParsecAdapter (string) -import ElmFormat.ImportInfo (ImportInfo(..)) -import ElmFormat.Render.Box (formatExpression, syntaxParens, SyntaxContext (SyntaxSeparated)) -import ElmVersion -import Parse.TestHelpers -import Reporting.Annotation (Located) -import Data.Word (Word16) -import GHC.Int (Int64) - - -pending :: ASTNS Located [UppercaseIdentifier] 'ExpressionNK -pending = at 0 0 0 0 $ Unit [] - - -example :: String -> String -> ASTNS Located [UppercaseIdentifier] 'ExpressionNK -> TestTree -example name input expected = - testCase name $ - assertParse (expr Elm_0_19) input expected - - -importInfo :: Ord ns => ImportInfo ns -importInfo = - ImportInfo mempty Bimap.empty mempty mempty mempty - - -example' :: String -> String -> String -> TestTree -example' name input expected = - testCase name $ - assertParse (fmap (Text.unpack . Box.render . syntaxParens SyntaxSeparated . formatExpression Elm_0_19 importInfo . I.convert (Identity . extract)) (expr Elm_0_19)) input expected - - -commentedIntExpr :: (Word16, Word16, Word16, Word16) -> String -> String -> Int64 -> Commented ([Comment], [Comment]) (ASTNS Located ns 'ExpressionNK) -commentedIntExpr (a,b,c,d) preComment postComment i = - C ([BlockComment [preComment]], [BlockComment [postComment]]) (at a b c d $ Literal $ IntNum i DecimalInt) - -commentedIntExpr' :: (Word16, Word16, Word16, Word16) -> String -> Int64 -> Commented ([Comment], [a]) (ASTNS Located ns 'ExpressionNK) -commentedIntExpr' (a,b,c,d) preComment i = - C ([BlockComment [preComment]], []) (at a b c d $ Literal $ IntNum i DecimalInt) - - -commentedIntExpr'' :: (Word16, Word16, Word16, Word16) -> String -> Int64 -> Commented [Comment] (ASTNS Located ns 'ExpressionNK) -commentedIntExpr'' (a,b,c,d) preComment i = - C [BlockComment [preComment]] $ at a b c d $ Literal $ IntNum i DecimalInt - - -intExpr :: (Word16, Word16, Word16, Word16) -> Int64 -> ASTNS Located ns 'ExpressionNK -intExpr (a,b,c,d) i = at a b c d $ Literal $ IntNum i DecimalInt - -intExpr' :: (Word16, Word16, Word16, Word16) -> Int64 -> Commented ([a1], [a2]) (ASTNS Located ns 'ExpressionNK) -intExpr' (a,b,c,d) i = - C ([], []) (at a b c d $ Literal $ IntNum i DecimalInt) - -intExpr'' :: (Word16, Word16, Word16, Word16) -> Int64 -> Commented [a] (ASTNS Located ns 'ExpressionNK) -intExpr'' (a,b,c,d) i = - C [] $ at a b c d $ Literal $ IntNum i DecimalInt - - -test_tests :: TestTree -test_tests = - testGroup "Parse.Expression" - [ testGroup "Unit" - [ example "" "()" $ at 1 1 1 3 $ Unit [] - , example "whitespace" "( )" $ at 1 1 1 4 $ Unit [] - , example "comments" "({-A-})" $ at 1 1 1 8 $ Unit [BlockComment ["A"]] - , example "newlines" "(\n )" $ at 1 1 2 3 $ Unit [] - ] - - , testGroup "Literal" - [ example "" "1" $ at 1 1 1 2 (Literal (IntNum 1 DecimalInt)) - - , testGroup "Boolean" - [ example "True" "True" $ at 1 1 1 5 $ Literal $ Boolean True - , example "False" "False" $ at 1 1 1 6 $ Literal $ Boolean False - ] - ] - - , testGroup "variable" - [ example "lowercase" "foo" $ at 1 1 1 4 $ VarExpr $ VarRef [] $ LowercaseIdentifier "foo" - , example "uppercase" "Bar" $ at 1 1 1 4 $ VarExpr $ TagRef [] $ UppercaseIdentifier "Bar" - , example "qualified" "Bar.Baz.foo" $ at 1 1 1 12 $ VarExpr $ VarRef [UppercaseIdentifier "Bar", UppercaseIdentifier "Baz"] $ LowercaseIdentifier "foo" - - , testGroup "symbolic operator" - [ example "" "(+)" $ at 1 1 1 4 $ VarExpr $ (OpRef $ SymbolIdentifier "+") - , testCase "does not allow whitespace" $ - assertParseFailure (expr Elm_0_19) "( + )" - , testCase "doew not allow comments" $ - assertParseFailure (expr Elm_0_19) "({-A-}+{-B-})" - ] - ] - - , testGroup "function application" - [ example "" "f 7 8" $ at 1 1 1 6 $ App (at 1 1 1 2 $ VarExpr $ VarRef [] $ LowercaseIdentifier "f") [intExpr'' (1,3,1,4) 7, intExpr'' (1,5,1,6) 8] (FAJoinFirst JoinAll) - , example "argument starts with minus" "f -9 -x" $ at 1 1 1 8 $ App (at 1 1 1 2 $ VarExpr $ VarRef [] $ LowercaseIdentifier "f") [intExpr'' (1,3,1,5) (-9), C [] $ at 1 6 1 8 $ Unary Negative $ at 1 7 1 8 $ VarExpr $ VarRef [] $ LowercaseIdentifier "x"] (FAJoinFirst JoinAll) - , example "comments" "f{-A-}7{-B-}8" $ at 1 1 1 14 $ App (at 1 1 1 2 $ VarExpr $ VarRef [] $ LowercaseIdentifier "f") [commentedIntExpr'' (1,7,1,8) "A" 7, commentedIntExpr'' (1,13,1,14) "B" 8] (FAJoinFirst JoinAll) - , example "newlines (1)" "f 7\n 8" $ at 1 1 2 3 $ App (at 1 1 1 2 $ VarExpr $ VarRef [] $ LowercaseIdentifier "f") [intExpr'' (1,3,1,4) 7, intExpr'' (2,2,2,3) 8] (FAJoinFirst SplitAll) - , example "newlines (2)" "f\n 7\n 8" $ at 1 1 3 3 $ App (at 1 1 1 2 $ VarExpr $ VarRef [] $ LowercaseIdentifier "f") [intExpr'' (2,2,2,3) 7, intExpr'' (3,2,3,3) 8] FASplitFirst - , example "newlines and comments" "f\n {-A-}7\n {-B-}8" $ at 1 1 3 8 $ App (at 1 1 1 2 $ VarExpr $ VarRef [] $ LowercaseIdentifier "f") [commentedIntExpr'' (2,7,2,8) "A" 7, commentedIntExpr'' (3,7,3,8) "B" 8] FASplitFirst - ] - - , testGroup "unary operators" - [ testGroup "negative" - [ example "" "-True" $ at 1 1 1 6 $ Unary Negative $ at 1 2 1 6 $ Literal $ Boolean True - , testCase "must not have whitespace" $ - assertParseFailure (expr Elm_0_19) "- True" - , testCase "must not have comment" $ - assertParseFailure (expr Elm_0_19) "-{- -}True" - , testCase "does not apply to '-'" $ - assertParseFailure (expr Elm_0_19) "--True" - , testCase "does not apply to '.'" $ - assertParseFailure (expr Elm_0_19) "-.foo" - ] - ] - - , testGroup "binary operators" - [ example "" "7+8<<>>9" $ at 1 1 1 9 $ Binops (intExpr (1,1,1,2) 7) [BinopsClause [] (OpRef $ SymbolIdentifier "+") [] (intExpr (1,3,1,4) 8), BinopsClause [] (OpRef $ SymbolIdentifier "<<>>") [] (intExpr (1,8,1,9) 9)] False - , example "minus with no whitespace" "9-1" $ at 1 1 1 4 $ Binops (intExpr (1,1,1,2) 9) [BinopsClause [] (OpRef $ SymbolIdentifier "-") [] (intExpr (1,3,1,4) 1)] False - , example "backticks" "7`plus`8`shift`9" $ at 1 1 1 17 $ Binops (intExpr (1,1,1,2) 7) [BinopsClause [] (VarRef [] $ LowercaseIdentifier "plus") [] (intExpr (1,8,1,9) 8), BinopsClause [] (VarRef [] $ LowercaseIdentifier "shift") [] (intExpr (1,16,1,17) 9)] False - , example "whitespace" "7 + 8 <<>> 9" $ at 1 1 1 13 $ Binops (intExpr (1,1,1,2) 7) [BinopsClause [] (OpRef $ SymbolIdentifier "+") [] (intExpr (1,5,1,6) 8), BinopsClause [] (OpRef $ SymbolIdentifier "<<>>") [] (intExpr (1,12,1,13) 9)] False - , example "comments" "7{-A-}+{-B-}8{-C-}<<>>{-D-}9" $ at 1 1 1 29 $ Binops (intExpr (1,1,1,2) 7) [BinopsClause [BlockComment ["A"]] (OpRef $ SymbolIdentifier "+") [BlockComment ["B"]] (intExpr (1,13,1,14) 8), BinopsClause [BlockComment ["C"]] (OpRef $ SymbolIdentifier "<<>>") [BlockComment ["D"]] (intExpr (1,28,1,29) 9)] False - , example "newlines" "7\n +\n 8\n <<>>\n 9" $ at 1 1 5 3 $ Binops (intExpr (1,1,1,2) 7) [BinopsClause [] (OpRef $ SymbolIdentifier "+") [] (intExpr (3,2,3,3) 8), BinopsClause [] (OpRef $ SymbolIdentifier "<<>>") [] (intExpr (5,2,5,3) 9)] True - ] - - , testGroup "parentheses" - [ example "" "(1)" $ at 1 1 1 4 $ Parens $ intExpr' (1,2,1,3) 1 - , example "whitespace" "( 1 )" $ at 1 1 1 6 $ Parens $ intExpr' (1,3,1,4) 1 - , example "comments" "({-A-}1{-B-})" $ at 1 1 1 14 $ Parens $ commentedIntExpr (1,7,1,8) "A" "B" 1 - , example "newlines" "(\n 1\n )" $ at 1 1 3 3 $ Parens $ intExpr' (2,2,2,3) 1 - ] - - , testGroup "empty list" - [ example' "empty" "[]" "[]\n" - , example' "whitespace" "[ ]" "[]\n" - , example' "comments" "[{-A-}]" "[{- A -}]\n" - , example' "newlines" "[\n ]" "[]\n" - ] - - , testGroup "List" - [ example' "" "[1,2,3]" "[ 1, 2, 3 ]\n" - , example' "single element" "[1]" "[ 1 ]\n" - , example' "whitespace" "[ 1 , 2 , 3 ]" "[ 1, 2, 3 ]\n" - , example' "comments" - "[{-A-}1{-B-},{-C-}2{-D-},{-E-}3{-F-}]" - "[ {- A -} 1\n\ - \\n\ - \{- B -}\n\ - \, {- C -} 2\n\ - \\n\ - \{- D -}\n\ - \, {- E -} 3\n\ - \\n\ - \{- F -}\n\ - \]\n" - , example' "newlines" - "[\n 1\n ,\n 2\n ,\n 3\n ]" - "[ 1\n, 2\n, 3\n]\n" - ] - - , testGroup "Range" - [ example "" "[7..9]" $ at 1 1 1 7 $ Range (intExpr' (1,2,1,3) 7) (intExpr' (1,5,1,6) 9) False - , example "whitespace" "[ 7 .. 9 ]" $ at 1 1 1 11 $ Range (intExpr' (1,3,1,4) 7) (intExpr' (1,8,1,9) 9) False - , example "comments" "[{-A-}7{-B-}..{-C-}9{-D-}]" $ at 1 1 1 27 $ Range (commentedIntExpr (1,7,1,8) "A" "B" 7) (commentedIntExpr (1,20,1,21) "C" "D" 9) False - , example "newlines" "[\n 7\n ..\n 9\n ]" $ at 1 1 5 3 $ Range (intExpr' (2,2,2,3) 7) (intExpr' (4,2,4,3) 9) True - ] - - , testGroup "Tuple" - [ example "" "(1,2)" $ at 1 1 1 6 $ Tuple [intExpr' (1,2,1,3) 1, intExpr' (1,4,1,5) 2] False - , example "whitespace" "( 1 , 2 )" $ at 1 1 1 10 $ Tuple [intExpr' (1,3,1,4) 1, intExpr' (1,7,1,8) 2] False - , example "comments" "({-A-}1{-B-},{-C-}2{-D-})" $ at 1 1 1 26 $ Tuple [commentedIntExpr (1,7,1,8) "A" "B" 1, commentedIntExpr (1,19,1,20) "C" "D" 2] False - , example "newlines" "(\n 1\n ,\n 2\n )" $ at 1 1 5 3 $ Tuple [intExpr' (2,2,2,3) 1, intExpr' (4,2,4,3) 2] True - ] - - , testGroup "tuple constructor" - [ example "" "(,,)" $ at 1 1 1 5 $ TupleFunction 3 - , testCase "does not allow whitespace (1)" $ assertParseFailure (expr Elm_0_19) "( ,,)" - , testCase "does not allow whitespace (2)" $ assertParseFailure (expr Elm_0_19) "(, ,)" - , testCase "does not allow whitespace (3)" $ assertParseFailure (expr Elm_0_19) "(,, )" - , testCase "does not allow comments (1)" $ assertParseFailure (expr Elm_0_19) "({-A-},,)" - , testCase "does not allow comments (2)" $ assertParseFailure (expr Elm_0_19) "(,{-A-},)" - , testCase "does not allow comments (3)" $ assertParseFailure (expr Elm_0_19) "(,,{-A-})" - ] - - , testGroup "Record" - [ testGroup "empty" - [ example' "" "{}" "{}\n" - , example' "whitespace" "{ }" "{}\n" - , example' "comments" "{{-A-}}" "{{- A -}}\n" - ] - - , example' "" - "{x=7,y=8}" - "{ x = 7, y = 8 }\n" - , example' "single field" - "{x=7}" - "{ x = 7 }\n" - , example' "whitespace" - "{ x = 7 , y = 8 }" - "{ x = 7, y = 8 }\n" - , example' "comments" - "{{-A-}x{-B-}={-C-}7{-D-},{-E-}y{-F-}={-G-}8{-H-}}" - "{ {- A -} x {- B -} = {- C -} 7\n\n{- D -}\n, {- E -} y {- F -} = {- G -} 8\n\n{- H -}\n}\n" - , example' "single field with comments" - "{{-A-}x{-B-}={-C-}7{-D-}}" - "{ {- A -} x {- B -} = {- C -} 7\n\n{- D -}\n}\n" - , example' "newlines" - "{\n x\n =\n 7\n ,\n y\n =\n 8\n }" - "{ x =\n 7\n, y =\n 8\n}\n" - ] - - , testGroup "Record update" - [ example' "" - "{a|x=7,y=8}" - "{ a | x = 7, y = 8 }\n" - , example' "single field" - "{a|x=7}" - "{ a | x = 7 }\n" - , example' "whitespace" - "{ a | x = 7 , y = 8 }" - "{ a | x = 7, y = 8 }\n" - , example' "comments" - "{{-A-}a{-B-}|{-C-}x{-D-}={-E-}7{-F-},{-G-}y{-H-}={-I-}8{-J-}}" - "{ {- A -} a {- B -}\n | {- C -} x {- D -} = {- E -} 7\n\n {- F -}\n , {- G -} y {- H -} = {- I -} 8\n\n {- J -}\n}\n" - , example' "newlines" - "{\n a\n |\n x\n =\n 7\n ,\n y\n =\n 8\n }" - "{ a\n | x =\n 7\n , y =\n 8\n}\n" - , testCase "only allows simple base" $ - assertParseFailure (expr Elm_0_19) "{9|x=7}" - , testCase "only allows simple base" $ - assertParseFailure (expr Elm_0_19) "{{}|x=7}" - , example' "no fields (elm-compiler does not allow this)" - "{a|}" - "{ a | }\n" - ] - - , testGroup "record access" - [ example "" "x.f1" $ at 1 1 1 5 (Access (at 1 1 1 2 (VarExpr (VarRef [] $ LowercaseIdentifier "x"))) (LowercaseIdentifier "f1")) - , example "nested" "x.f1.f2" $ at 1 1 1 8 (Access (at 1 1 1 5 (Access (at 1 1 1 2 (VarExpr (VarRef [] $ LowercaseIdentifier "x"))) (LowercaseIdentifier "f1"))) (LowercaseIdentifier "f2")) - , testCase "does not allow symbolic field names" $ - assertParseFailure (expr Elm_0_19) "x.+" - , testCase "does not allow symbolic field names" $ - assertParseFailure (expr Elm_0_19) "x.(+)" - ] - - , testGroup "record access fuction" - [ example "" ".f1" $ at 1 1 1 4 $ AccessFunction (LowercaseIdentifier "f1") - ] - - , testGroup "lambda" - [ example "" "\\x y->9" $ at 1 1 1 8 $ Lambda [C [] ( at 1 2 1 3 $ VarPattern $ LowercaseIdentifier "x"), C [] ( at 1 4 1 5 $ VarPattern $ LowercaseIdentifier "y")] [] (intExpr (1,7,1,8) 9) False - , example "single parameter" "\\x->9" $ at 1 1 1 6 $ Lambda [C [] ( at 1 2 1 3 $ VarPattern $ LowercaseIdentifier "x")] [] (intExpr (1,5,1,6) 9) False - , example "whitespace" "\\ x y -> 9" $ at 1 1 1 11 $ Lambda [C [] ( at 1 3 1 4 $ VarPattern $ LowercaseIdentifier "x"), C [] ( at 1 5 1 6 $ VarPattern $ LowercaseIdentifier "y")] [] (intExpr (1,10,1,11) 9) False - , example "comments" "\\{-A-}x{-B-}y{-C-}->{-D-}9" $ at 1 1 1 27 $ Lambda [C [BlockComment ["A"]] ( at 1 7 1 8 $ VarPattern $ LowercaseIdentifier "x"), C [BlockComment ["B"]] ( at 1 13 1 14 $ VarPattern $ LowercaseIdentifier "y")] [BlockComment ["C"], BlockComment ["D"]] (intExpr (1,26,1,27) 9) False - , example "newlines" "\\\n x\n y\n ->\n 9" $ at 1 1 5 3 $ Lambda [C [] ( at 2 2 2 3 $ VarPattern $ LowercaseIdentifier "x"), C [] ( at 3 2 3 3 $ VarPattern $ LowercaseIdentifier "y")] [] (intExpr (5,2,5,3) 9) True - , testCase "arrow must not contain whitespace" $ - assertParseFailure (expr Elm_0_19) "\\x y - > 9" - ] - - , testGroup "if statement" - [ example "" "if x then y else z" $ at 1 1 1 19 (If (IfClause (C ([], []) (at 1 4 1 5 (VarExpr (VarRef [] $ LowercaseIdentifier "x")))) (C ([], []) (at 1 11 1 12 (VarExpr (VarRef [] $ LowercaseIdentifier "y"))))) [] (C [] (at 1 18 1 19 (VarExpr (VarRef [] $ LowercaseIdentifier "z"))))) - , example "comments" "if{-A-}x{-B-}then{-C-}y{-D-}else{-E-}if{-F-}x_{-G-}then{-H-}y_{-I-}else{-J-}z" $ at 1 1 1 78 (If (IfClause (C ([BlockComment ["A"]], [BlockComment ["B"]]) (at 1 8 1 9 (VarExpr (VarRef [] $ LowercaseIdentifier "x")))) (C ([BlockComment ["C"]], [BlockComment ["D"]]) (at 1 23 1 24 (VarExpr (VarRef [] $ LowercaseIdentifier "y"))))) [C [BlockComment ["E"]] (IfClause (C ([BlockComment ["F"]], [BlockComment ["G"]]) (at 1 45 1 47 (VarExpr (VarRef [] $ LowercaseIdentifier "x_")))) (C ([BlockComment ["H"]], [BlockComment ["I"]]) (at 1 61 1 63 (VarExpr (VarRef [] $ LowercaseIdentifier "y_")))))] (C [BlockComment ["J"]] (at 1 77 1 78 (VarExpr (VarRef [] $ LowercaseIdentifier "z"))))) - , example "else if" "if x1 then y1 else if x2 then y2 else if x3 then y3 else z" $ at 1 1 1 59 (If (IfClause (C ([], []) (at 1 4 1 6 (VarExpr (VarRef [] $ LowercaseIdentifier "x1")))) (C ([], []) (at 1 12 1 14 (VarExpr (VarRef [] $ LowercaseIdentifier "y1"))))) [C [] (IfClause (C ([], []) (at 1 23 1 25 (VarExpr (VarRef [] $ LowercaseIdentifier "x2")))) (C ([], []) (at 1 31 1 33 (VarExpr (VarRef [] $ LowercaseIdentifier "y2"))))),C [] (IfClause (C ([], []) (at 1 42 1 44 (VarExpr (VarRef [] $ LowercaseIdentifier "x3")))) (C ([], []) (at 1 50 1 52 (VarExpr (VarRef [] $ LowercaseIdentifier "y3")))))] (C [] (at 1 58 1 59 (VarExpr (VarRef [] $ LowercaseIdentifier "z"))))) - , example "newlines" "if\n x\n then\n y\n else\n z" $ at 1 1 6 3 (If (IfClause (C ([], []) (at 2 2 2 3 (VarExpr (VarRef [] $ LowercaseIdentifier "x")))) (C ([], []) (at 4 2 4 3 (VarExpr (VarRef [] $ LowercaseIdentifier "y"))))) [] (C [] (at 6 2 6 3 (VarExpr (VarRef [] $ LowercaseIdentifier "z"))))) - ] - - , testGroup "let statement" - [ example "" "let a=b in z" $ at 1 1 1 13 (Let [at 1 5 1 8 $ LetCommonDeclaration $ at 1 5 1 8 $ Definition (at 1 5 1 6 (VarPattern (LowercaseIdentifier "a"))) [] [] (at 1 7 1 8 (VarExpr (VarRef [] $ LowercaseIdentifier "b")))] [] (at 1 12 1 13 (VarExpr (VarRef [] $ LowercaseIdentifier "z")))) - , example "multiple declarations" "let a=b\n c=d\nin z" $ at 1 1 3 5 (Let [at 1 5 1 8 $ LetCommonDeclaration $ at 1 5 1 8 $ Definition (at 1 5 1 6 (VarPattern (LowercaseIdentifier "a"))) [] [] (at 1 7 1 8 (VarExpr (VarRef [] $ LowercaseIdentifier "b"))),at 2 5 2 8 $ LetCommonDeclaration $ at 2 5 2 8 $ Definition (at 2 5 2 6 (VarPattern (LowercaseIdentifier "c"))) [] [] (at 2 7 2 8 (VarExpr (VarRef [] $ LowercaseIdentifier "d")))] [] (at 3 4 3 5 (VarExpr (VarRef [] $ LowercaseIdentifier "z")))) - , example "multiple declarations" "let\n a=b\n c=d\nin z" $ at 1 1 4 5 (Let [at 2 2 2 5 $ LetCommonDeclaration $ at 2 2 2 5 $ Definition (at 2 2 2 3 (VarPattern (LowercaseIdentifier "a"))) [] [] (at 2 4 2 5 (VarExpr (VarRef [] $ LowercaseIdentifier "b"))),at 3 2 3 5 $ LetCommonDeclaration $ at 3 2 3 5 $ Definition (at 3 2 3 3 (VarPattern (LowercaseIdentifier "c"))) [] [] (at 3 4 3 5 (VarExpr (VarRef [] $ LowercaseIdentifier "d")))] [] (at 4 4 4 5 (VarExpr (VarRef [] $ LowercaseIdentifier "z")))) - , example "whitespace" "let a = b in z" $ at 1 1 1 15 (Let [at 1 5 1 10 $ LetCommonDeclaration $ at 1 5 1 10 $ Definition (at 1 5 1 6 (VarPattern (LowercaseIdentifier "a"))) [] [] (at 1 9 1 10 (VarExpr (VarRef [] $ LowercaseIdentifier "b")))] [] (at 1 14 1 15 (VarExpr (VarRef [] $ LowercaseIdentifier "z")))) - , example "comments" "let{-A-}a{-B-}={-C-}b{-D-}in{-E-}z" $ at 1 1 1 35 (Let [at 1 4 1 9 $ LetComment (BlockComment ["A"]),at 1 9 1 22 $ LetCommonDeclaration $ at 1 9 1 22 $ Definition (at 1 9 1 10 (VarPattern (LowercaseIdentifier "a"))) [] [BlockComment ["B"],BlockComment ["C"]] (at 1 21 1 22 (VarExpr (VarRef [] $ LowercaseIdentifier "b"))),at 1 22 1 27 $ LetComment (BlockComment ["D"])] [BlockComment ["E"]] (at 1 34 1 35 (VarExpr (VarRef [] $ LowercaseIdentifier "z")))) - , example "newlines" "let\n a\n =\n b\nin\n z" $ at 1 1 6 3 (Let [at 2 2 4 3 $ LetCommonDeclaration $ at 2 2 4 3 $ Definition (at 2 2 2 3 (VarPattern (LowercaseIdentifier "a"))) [] [] (at 4 2 4 3 (VarExpr (VarRef [] $ LowercaseIdentifier "b")))] [] (at 6 2 6 3 (VarExpr (VarRef [] $ LowercaseIdentifier "z")))) - , testCase "must have at least one definition" $ - assertParseFailure (expr Elm_0_19) "let in z" - , testGroup "declarations must start at the same column" $ - [ testCase "(1)" $ assertParseFailure (expr Elm_0_19) "let a=b\n c=d\nin z" - , testCase "(2)" $ assertParseFailure (expr Elm_0_19) "let a=b\n c=d\nin z" - , testCase "(3)" $ assertParseFailure (expr Elm_0_19) "let a=b\n c=d\nin z" - ] - ] - - , testGroup "case statement" - [ example "" "case 9 of\n 1->10\n _->20" $ at 1 1 3 7 (Case (C ([], []) (at 1 6 1 7 (Literal (IntNum 9 DecimalInt))),False) [at 2 2 2 7 $ CaseBranch [] [] [] (at 2 2 2 3 $ LiteralPattern $ IntNum 1 DecimalInt) (at 2 5 2 7 $ Literal $ IntNum 10 DecimalInt), at 2 7 3 7 $ CaseBranch [] [] [] (at 3 2 3 3 Anything) (at 3 5 3 7 $ Literal $ IntNum 20 DecimalInt)]) - , example "no newline after 'of'" "case 9 of 1->10\n _->20" $ at 1 1 2 16 (Case (C ([], []) (at 1 6 1 7 (Literal (IntNum 9 DecimalInt))),False) [at 1 11 1 16 $ CaseBranch [] [] [] (at 1 11 1 12 $ LiteralPattern $ IntNum 1 DecimalInt) (at 1 14 1 16 $ Literal $ IntNum 10 DecimalInt), at 1 16 2 16 $ CaseBranch [] [] [] (at 2 11 2 12 Anything) (at 2 14 2 16 $ Literal $ IntNum 20 DecimalInt)]) - , example "whitespace" "case 9 of\n 1 -> 10\n _ -> 20" $ at 1 1 3 9 (Case (C ([], []) (at 1 6 1 7 (Literal (IntNum 9 DecimalInt))),False) [at 2 2 2 9 $ CaseBranch [] [] [] (at 2 2 2 3 $ LiteralPattern $ IntNum 1 DecimalInt) (at 2 7 2 9 $ Literal $ IntNum 10 DecimalInt), at 2 9 3 9 $ CaseBranch [] [] [] (at 3 2 3 3 Anything) (at 3 7 3 9 $ Literal $ IntNum 20 DecimalInt)]) - , example "comments" "case{-A-}9{-B-}of{-C-}\n{-D-}1{-E-}->{-F-}10{-G-}\n{-H-}_{-I-}->{-J-}20" $ at 1 1 3 21 (Case (C ([BlockComment ["A"]], [BlockComment ["B"]]) (at 1 10 1 11 (Literal (IntNum 9 DecimalInt))),False) [at 2 6 2 21 $ CaseBranch [BlockComment ["C"],BlockComment ["D"]] [BlockComment ["E"]] [BlockComment ["F"]] (at 2 6 2 7 $ LiteralPattern $ IntNum 1 DecimalInt) (at 2 19 2 21 $ Literal $ IntNum 10 DecimalInt), at 2 21 3 21 $ CaseBranch [BlockComment ["G"],BlockComment ["H"]] [BlockComment ["I"]] [BlockComment ["J"]] (at 3 6 3 7 Anything) (at 3 19 3 21 $ Literal $ IntNum 20 DecimalInt)]) - , example "newlines" "case\n 9\n of\n 1\n ->\n 10\n _\n ->\n 20" $ at 1 1 9 4 (Case (C ([], []) (at 2 2 2 3 (Literal (IntNum 9 DecimalInt))),True) [at 4 2 6 4 $ CaseBranch [] [] [] (at 4 2 4 3 $ LiteralPattern $ IntNum 1 DecimalInt) (at 6 2 6 4 $ Literal $ IntNum 10 DecimalInt), at 6 4 9 4 $ CaseBranch [] [] [] (at 7 2 7 3 Anything) (at 9 2 9 4 $ Literal $ IntNum 20 DecimalInt)]) - , testCase "should not consume trailing whitespace" $ - assertParse (expr Elm_0_19>> string "\nX") "case 9 of\n 1->10\n _->20\nX" $ "\nX" - , testGroup "clauses must start at the same column" - [ testCase "(1)" $ assertParseFailure (expr Elm_0_19) "case 9 of\n 1->10\n_->20" - , testCase "(2)" $ assertParseFailure (expr Elm_0_19) "case 9 of\n 1->10\n _->20" - , testCase "(3)" $ assertParseFailure (expr Elm_0_19) "case 9 of\n 1->10\n _->20" - ] - ] - ] diff --git a/elm-format-lib/test/Parse/HelpersSpec.hs b/elm-format-lib/test/Parse/HelpersSpec.hs new file mode 100644 index 000000000..41b18a60d --- /dev/null +++ b/elm-format-lib/test/Parse/HelpersSpec.hs @@ -0,0 +1,35 @@ +module Parse.HelpersSpec where + +import Test.Hspec hiding (example) + +import AST.V0_16 +import Parse.Helpers (parens'') +import Parse.IParser +import Parse.ParsecAdapter (lower) + +import Parse.TestHelpers + + +example :: (Show a, Eq a) => IParser a -> String -> String -> a -> SpecWith () +example parser name input expected = + it name $ + assertParse parser input expected + + +x :: IParser String +x = (\x -> [x]) <$> lower + + +spec :: Spec +spec = describe "Parse.Helpers" $ do + describe "parens''" $ do + example (parens'' x) "single term" "(x)" $ Right [C ([], []) "x"] + example (parens'' x) "whitespace" "( x )" $ Right [C ([], []) "x"] + example (parens'' x) "comments" "({-A-}x{-B-})" $ Right [C ([BlockComment ["A"]], [BlockComment ["B"]]) "x"] + + example (parens'' x) "multiple terms" "(a,b,c)" $ Right [C ([], []) "a", C ([], []) "b", C ([], []) "c"] + example (parens'' x) "whitespace" "( a , b , c )" $ Right [C ([], []) "a", C ([], []) "b", C ([], []) "c"] + + example (parens'' x) "no terms" "()" $ Left [] + example (parens'' x) "whitespace" "( )" $ Left [] + example (parens'' x) "comments" "({-A-})" $ Left [BlockComment ["A"]] diff --git a/elm-format-lib/test/Parse/HelpersTest.hs b/elm-format-lib/test/Parse/HelpersTest.hs deleted file mode 100644 index 5c99b77a6..000000000 --- a/elm-format-lib/test/Parse/HelpersTest.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Parse.HelpersTest where - -import Test.Tasty -import Test.Tasty.HUnit - -import AST.V0_16 -import Parse.Helpers (parens'') -import Parse.IParser -import Parse.ParsecAdapter (lower) - -import Parse.TestHelpers - - -example :: (Show a, Eq a) => IParser a -> TestName -> String -> a -> TestTree -example parser name input expected = - testCase name $ - assertParse parser input expected - - -x :: IParser String -x = (\x -> [x]) <$> lower - - -test_tests :: TestTree -test_tests = - testGroup "Parse.Helpers" - [ testGroup "parens''" - [ example (parens'' x) "single term" "(x)" $ Right [C ([], []) "x"] - , example (parens'' x) "whitespace" "( x )" $ Right [C ([], []) "x"] - , example (parens'' x) "comments" "({-A-}x{-B-})" $ Right [C ([BlockComment ["A"]], [BlockComment ["B"]]) "x"] - - , example (parens'' x) "multiple terms" "(a,b,c)" $ Right [C ([], []) "a", C ([], []) "b", C ([], []) "c"] - , example (parens'' x) "whitespace" "( a , b , c )" $ Right [C ([], []) "a", C ([], []) "b", C ([], []) "c"] - - , example (parens'' x) "no terms" "()" $ Left [] - , example (parens'' x) "whitespace" "( )" $ Left [] - , example (parens'' x) "comments" "({-A-})" $ Left [BlockComment ["A"]] - ] - ] diff --git a/elm-format-lib/test/Parse/LiteralSpec.hs b/elm-format-lib/test/Parse/LiteralSpec.hs new file mode 100644 index 000000000..b07abafd9 --- /dev/null +++ b/elm-format-lib/test/Parse/LiteralSpec.hs @@ -0,0 +1,74 @@ +module Parse.LiteralSpec where + +import Test.Hspec hiding (example) + +import ElmFormat.Render.Box (formatLiteral) +import Parse.Literal (literal) +import Parse.TestHelpers (assertParse, assertParseFailure) + +import qualified ElmVersion +import qualified Data.Text as Text +import qualified Box +import qualified Data.Fix as Fix +import qualified ElmFormat.Render.ElmStructure as ElmStructure + + +example :: String -> String -> String -> SpecWith () +example name input expected = + it name $ + assertParse (fmap (Text.unpack . Box.render . Fix.cata ElmStructure.render . formatLiteral ElmVersion.Elm_0_18) literal) input expected + + +spec :: Spec +spec = describe "Parse.Literal" $ do + describe "Int" $ do + example "" "99" "99\n" + example "negative" "-99" "-99\n" + describe "hexadecimal" $ do + example "small" "0xfF" "0xFF\n" + example "medium" "0xfF0" "0x0FF0\n" + example "large" "0xfF000" "0x000FF000\n" + example "huge" "0xfF0000000" "0x0000000FF0000000\n" + it "hexadecimal must start with 0" $ + assertParseFailure literal "xFF" + it "hexadecimal, must contain digits" $ + assertParseFailure literal "0x" + + describe "Float" $ do + example "" "0.1" "0.1\n" + example "negative" "-0.1" "-0.1\n" + example "exponent" "9e3" "9.0e3\n" + example "positive exponent" "9e+3" "9.0e3\n" + example "negative exponent" "9e-3" "9.0e-3\n" + example "capital exponent" "9E3" "9.0e3\n" + it "exponent must have exponent digits" $ + assertParseFailure literal "9E" + it "exponent must have digits" $ + assertParseFailure literal "e3" + example "exponent and decimal" "9.1e3" "9.1e3\n" + it "exponent and decimal, must have decimal digits" $ + assertParseFailure literal "9.e3" + it "must have digits" $ + assertParseFailure literal "." + it "must start with a digit" $ + assertParseFailure literal ".1" + it "decimal, must have decimal digits" $ + assertParseFailure literal "99." + + describe "String" $ do + example "" "\"hello\"" "\"hello\"\n" + example "empty" "\"\"" "\"\"\n" + example "escaped double quote" "\"\\\"\"" "\"\\\"\"\n" + + describe "multiline String" $ do + example "" + "\"\"\"hello\n\"\n\"\"\"" + "\"\"\"hello\n\"\n\"\"\"\n" + + describe "Char" $ do + example "" "\'a\'" "\'a\'\n" + example "escaped single quote" "\'\\\'\'" "\'\\\'\'\n" + it "Char (must have one character)" $ + assertParseFailure literal "\'\'" + it "Char (must have only one character)" $ + assertParseFailure literal "\'ab\'" diff --git a/elm-format-lib/test/Parse/LiteralTest.hs b/elm-format-lib/test/Parse/LiteralTest.hs deleted file mode 100644 index fa92ba111..000000000 --- a/elm-format-lib/test/Parse/LiteralTest.hs +++ /dev/null @@ -1,81 +0,0 @@ -module Parse.LiteralTest where - -import Test.Tasty -import Test.Tasty.HUnit - -import Box (render) -import Data.Text (unpack) -import ElmFormat.Render.Box (formatLiteral) -import Parse.Literal (literal) -import Parse.TestHelpers (assertParse, assertParseFailure) - -import qualified ElmVersion - - -example :: String -> String -> String -> TestTree -example name input expected = - testCase name $ - assertParse (fmap (unpack . render . formatLiteral ElmVersion.Elm_0_18) literal) input expected - - -test_tests :: TestTree -test_tests = - testGroup "Parse.Literal" - [ testGroup "Int" - [ example "" "99" "99\n" - , example "negative" "-99" "-99\n" - , testGroup "hexadecimal" - [ example "small" "0xfF" "0xFF\n" - , example "medium" "0xfF0" "0x0FF0\n" - , example "large" "0xfF000" "0x000FF000\n" - , example "huge" "0xfF0000000" "0x0000000FF0000000\n" - ] - , testCase "hexadecimal must start with 0" $ - assertParseFailure literal "xFF" - , testCase "hexadecimal, must contain digits" $ - assertParseFailure literal "0x" - ] - - , testGroup "Float" - [ example "" "0.1" "0.1\n" - , example "negative" "-0.1" "-0.1\n" - , example "exponent" "9e3" "9.0e3\n" - , example "positive exponent" "9e+3" "9.0e3\n" - , example "negative exponent" "9e-3" "9.0e-3\n" - , example "capital exponent" "9E3" "9.0e3\n" - , testCase "exponent must have exponent digits" $ - assertParseFailure literal "9E" - , testCase "exponent must have digits" $ - assertParseFailure literal "e3" - , example "exponent and decimal" "9.1e3" "9.1e3\n" - , testCase "exponent and decimal, must have decimal digits" $ - assertParseFailure literal "9.e3" - , testCase "must have digits" $ - assertParseFailure literal "." - , testCase "must start with a digit" $ - assertParseFailure literal ".1" - , testCase "decimal, must have decimal digits" $ - assertParseFailure literal "99." - ] - - , testGroup "String" - [ example "" "\"hello\"" "\"hello\"\n" - , example "empty" "\"\"" "\"\"\n" - , example "escaped double quote" "\"\\\"\"" "\"\\\"\"\n" - ] - - , testGroup "multiline String" - [ example "" - "\"\"\"hello\n\"\n\"\"\"" - "\"\"\"hello\n\"\n\"\"\"\n" - ] - - , testGroup "Char" - [ example "" "\'a\'" "\'a\'\n" - , example "escaped single quote" "\'\\\'\'" "\'\\\'\'\n" - , testCase "Char (must have one character)" $ - assertParseFailure literal "\'\'" - , testCase "Char (must have only one character)" $ - assertParseFailure literal "\'ab\'" - ] - ] diff --git a/elm-format-lib/test/Parse/PatternSpec.hs b/elm-format-lib/test/Parse/PatternSpec.hs new file mode 100644 index 000000000..2f5976535 --- /dev/null +++ b/elm-format-lib/test/Parse/PatternSpec.hs @@ -0,0 +1,87 @@ +module Parse.PatternSpec where + +import Test.Hspec hiding (example) + +import qualified Parse.Pattern +import AST.V0_16 +import AST.Structure +import ElmVersion +import Parse.IParser +import Reporting.Annotation (Located) + +import Parse.TestHelpers +import qualified Data.Indexed as I + + +expr :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'PatternNK) +expr = Parse.Pattern.expr + +example :: String -> String -> I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'PatternNK -> SpecWith () +example name input expected = + it name $ + assertParse (expr Elm_0_19) input expected + + +spec :: Spec +spec = describe "Parse.Pattern" $ do + example "wildcard" "_" $ at 1 1 1 2 Anything + + example "literal" "1" $ at 1 1 1 2 (LiteralPattern (IntNum 1 DecimalInt)) + + example "variable" "a" $ at 1 1 1 2 (VarPattern (LowercaseIdentifier "a")) + + describe "data" $ do + example "" "Just x y" $ at 1 1 1 9 $ DataPattern (at 1 1 1 5 $ CtorRef_ ([], UppercaseIdentifier "Just")) [C [] $ at 1 6 1 7 $ VarPattern (LowercaseIdentifier "x"),C [] (at 1 8 1 9 (VarPattern (LowercaseIdentifier "y")))] + example "single parameter" "Just x" $ at 1 1 1 7 $ DataPattern (at 1 1 1 5 $ CtorRef_ ([], UppercaseIdentifier "Just")) [C [] (at 1 6 1 7 (VarPattern (LowercaseIdentifier "x")))] + example "comments" "Just{-A-}x{-B-}y" $ at 1 1 1 17 $ DataPattern (at 1 1 1 5 $ CtorRef_ ([], UppercaseIdentifier "Just")) [C [BlockComment ["A"]] (at 1 10 1 11 (VarPattern (LowercaseIdentifier "x"))),C [BlockComment ["B"]] (at 1 16 1 17 (VarPattern (LowercaseIdentifier "y")))] + example "newlines" "Just\n x\n y" $ at 1 1 3 3 $ DataPattern (at 1 1 1 5 $ CtorRef_ ([], UppercaseIdentifier "Just")) [C [] (at 2 2 2 3 (VarPattern (LowercaseIdentifier "x"))),C [] (at 3 2 3 3 (VarPattern (LowercaseIdentifier "y")))] + + describe "unit" $ do + example "" "()" $ at 1 1 1 3 (UnitPattern []) + example "whitespace" "( )" $ at 1 1 1 4 (UnitPattern []) + example "comments" "({-A-})" $ at 1 1 1 8 (UnitPattern [BlockComment ["A"]]) + example "newlines" "(\n )" $ at 1 1 2 3 (UnitPattern []) + + describe "parentheses" $ do + example "" "(_)" $ at 1 2 1 3 Anything + example "whitespace" "( _ )" $ at 1 3 1 4 Anything + example "comments" "({-A-}_{-B-})" $ at 1 1 1 14 (PatternParens (C ([BlockComment ["A"]], [BlockComment ["B"]]) (at 1 7 1 8 Anything))) + example "newlines" "(\n _\n )" $ at 2 2 2 3 Anything + + describe "tuple" $ do + example "" "(x,y)" $ at 1 1 1 6 (TuplePattern [C ([], []) (at 1 2 1 3 (VarPattern (LowercaseIdentifier "x"))),C ([], []) (at 1 4 1 5 (VarPattern (LowercaseIdentifier "y")))]) + example "whitespace" "( x , y )" $ at 1 1 1 10 (TuplePattern [C ([], []) (at 1 3 1 4 (VarPattern (LowercaseIdentifier "x"))),C ([], []) (at 1 7 1 8 (VarPattern (LowercaseIdentifier "y")))]) + example "comments" "({-A-}x{-B-},{-C-}y{-D-})" $ at 1 1 1 26 (TuplePattern [C ([BlockComment ["A"]], [BlockComment ["B"]]) (at 1 7 1 8 (VarPattern (LowercaseIdentifier "x"))),C ([BlockComment ["C"]], [BlockComment ["D"]]) (at 1 19 1 20 (VarPattern (LowercaseIdentifier "y")))]) + example "newlines" "(\n x\n ,\n y\n )" $ at 1 1 5 3 (TuplePattern [C ([], []) (at 2 2 2 3 (VarPattern (LowercaseIdentifier "x"))),C ([], []) (at 4 2 4 3 (VarPattern (LowercaseIdentifier "y")))]) + + describe "empty list pattern" $ do + example "" "[]" $ at 1 1 1 3 (EmptyListPattern []) + example "whitespace" "[ ]" $ at 1 1 1 4 (EmptyListPattern []) + example "comments" "[{-A-}]" $ at 1 1 1 8 (EmptyListPattern [BlockComment ["A"]]) + example "newlines" "[\n ]" $ at 1 1 2 3 (EmptyListPattern []) + + describe "list" $ do + example "" "[x,y]" $ at 1 1 1 6 (ListPattern [C ([], []) (at 1 2 1 3 (VarPattern (LowercaseIdentifier "x"))),C ([], []) (at 1 4 1 5 (VarPattern (LowercaseIdentifier "y")))]) + example "single element" "[x]" $ at 1 1 1 4 (ListPattern [C ([], []) (at 1 2 1 3 (VarPattern (LowercaseIdentifier "x")))]) + example "whitespace" "[ x , y ]" $ at 1 1 1 10 (ListPattern [C ([], []) (at 1 3 1 4 (VarPattern (LowercaseIdentifier "x"))),C ([], []) (at 1 7 1 8 (VarPattern (LowercaseIdentifier "y")))]) + example "comments" "[{-A-}x{-B-},{-C-}y{-D-}]" $ at 1 1 1 26 (ListPattern [C ([BlockComment ["A"]], [BlockComment ["B"]]) (at 1 7 1 8 (VarPattern (LowercaseIdentifier "x"))),C ([BlockComment ["C"]], [BlockComment ["D"]]) (at 1 19 1 20 (VarPattern (LowercaseIdentifier "y")))]) + example "newlines" "[\n x\n ,\n y\n ]" $ at 1 1 5 3 (ListPattern [C ([], []) (at 2 2 2 3 (VarPattern (LowercaseIdentifier "x"))),C ([], []) (at 4 2 4 3 (VarPattern (LowercaseIdentifier "y")))]) + + describe "record" $ do + example "" "{a,b}" $ at 1 1 1 6 (RecordPattern [C ([], []) (LowercaseIdentifier "a"),C ([], []) (LowercaseIdentifier "b")]) + example "single element" "{a}" $ at 1 1 1 4 (RecordPattern [C ([], []) (LowercaseIdentifier "a")]) + example "whitespace" "{ a , b }" $ at 1 1 1 10 (RecordPattern [C ([], []) (LowercaseIdentifier "a"),C ([], []) (LowercaseIdentifier "b")]) + example "comments" "{{-A-}a{-B-},{-C-}b{-D-}}" $ at 1 1 1 26 (RecordPattern [C ([BlockComment ["A"]], [BlockComment ["B"]]) (LowercaseIdentifier "a"),C ([BlockComment ["C"]], [BlockComment ["D"]]) (LowercaseIdentifier "b")]) + example "newlines" "{\n a\n ,\n b\n }" $ at 1 1 5 3 (RecordPattern [C ([], []) (LowercaseIdentifier "a"),C ([], []) (LowercaseIdentifier "b")]) + example "empty" "{}" $ at 1 1 1 3 (EmptyRecordPattern []) + + describe "alias" $ do + example "" "_ as x" $ at 1 1 1 7 (Alias (C [] (at 1 1 1 2 Anything)) (C [] (LowercaseIdentifier "x"))) + example "left side has whitespace" "A b as x" $ at 1 1 1 9 $ Alias (C [] (at 1 1 1 4 $ DataPattern (at 1 1 1 2 $ CtorRef_ ([], UppercaseIdentifier "A")) [C [] ( at 1 3 1 4 (VarPattern (LowercaseIdentifier "b")))])) (C [] (LowercaseIdentifier "x")) + example "left side ctor without whitespace" "A as x" $ at 1 1 1 7 $ Alias (C [] (at 1 1 1 2 $ DataPattern (at 1 1 1 2 $ CtorRef_ ([], UppercaseIdentifier "A")) [])) (C [] (LowercaseIdentifier "x")) + example "comments" "_{-A-}as{-B-}x" $ at 1 1 1 15 (Alias (C [BlockComment ["A"]] (at 1 1 1 2 Anything)) (C [BlockComment ["B"]] (LowercaseIdentifier "x"))) + example "newlines" "_\n as\n x" $ at 1 1 3 3 (Alias (C [] (at 1 1 1 2 Anything)) (C [] (LowercaseIdentifier "x"))) + example "nested" "(_ as x)as y" $ at 1 1 1 13 (Alias (C [] (at 1 2 1 8 (Alias (C [] (at 1 2 1 3 Anything)) (C [] (LowercaseIdentifier "x"))))) (C [] (LowercaseIdentifier "y"))) + example "nested (whitespace)" "(_ as x) as y" $ at 1 1 1 14 (Alias (C [] (at 1 2 1 8 (Alias (C [] (at 1 2 1 3 Anything)) (C [] (LowercaseIdentifier "x"))))) (C [] (LowercaseIdentifier "y"))) + it "nesting required parentheses" $ + assertParseFailure (expr Elm_0_19) "_ as x as y" diff --git a/elm-format-lib/test/Parse/PatternTest.hs b/elm-format-lib/test/Parse/PatternTest.hs deleted file mode 100644 index 51f225ec5..000000000 --- a/elm-format-lib/test/Parse/PatternTest.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE DataKinds #-} -module Parse.PatternTest where - -import Test.Tasty -import Test.Tasty.HUnit - -import qualified Parse.Pattern -import AST.V0_16 -import AST.Structure -import ElmVersion -import Parse.IParser -import Reporting.Annotation (Located) - -import Parse.TestHelpers - - -expr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'PatternNK) -expr = Parse.Pattern.expr - -example :: String -> String -> ASTNS Located [UppercaseIdentifier] 'PatternNK -> TestTree -example name input expected = - testCase name $ - assertParse (expr Elm_0_19) input expected - - -test_tests :: TestTree -test_tests = - testGroup "Parse.Pattern" - [ example "wildcard" "_" $ at 1 1 1 2 Anything - - , example "literal" "1" $ at 1 1 1 2 (LiteralPattern (IntNum 1 DecimalInt)) - - , example "variable" "a" $ at 1 1 1 2 (VarPattern (LowercaseIdentifier "a")) - - , testGroup "data" - [ example "" "Just x y" $ at 1 1 1 9 $ DataPattern ([], UppercaseIdentifier "Just") [C [] $ at 1 6 1 7 $ VarPattern (LowercaseIdentifier "x"),C [] (at 1 8 1 9 (VarPattern (LowercaseIdentifier "y")))] - , example "single parameter" "Just x" $ at 1 1 1 7 $ DataPattern ([], UppercaseIdentifier "Just") [C [] (at 1 6 1 7 (VarPattern (LowercaseIdentifier "x")))] - , example "comments" "Just{-A-}x{-B-}y" $ at 1 1 1 17 $ DataPattern ([], UppercaseIdentifier "Just") [C [BlockComment ["A"]] (at 1 10 1 11 (VarPattern (LowercaseIdentifier "x"))),C [BlockComment ["B"]] (at 1 16 1 17 (VarPattern (LowercaseIdentifier "y")))] - , example "newlines" "Just\n x\n y" $ at 1 1 3 3 $ DataPattern ([], UppercaseIdentifier "Just") [C [] (at 2 2 2 3 (VarPattern (LowercaseIdentifier "x"))),C [] (at 3 2 3 3 (VarPattern (LowercaseIdentifier "y")))] - ] - - , testGroup "unit" - [ example "" "()" $ at 1 1 1 3 (UnitPattern []) - , example "whitespace" "( )" $ at 1 1 1 4 (UnitPattern []) - , example "comments" "({-A-})" $ at 1 1 1 8 (UnitPattern [BlockComment ["A"]]) - , example "newlines" "(\n )" $ at 1 1 2 3 (UnitPattern []) - ] - - , testGroup "parentheses" - [ example "" "(_)" $ at 1 2 1 3 Anything - , example "whitespace" "( _ )" $ at 1 3 1 4 Anything - , example "comments" "({-A-}_{-B-})" $ at 1 1 1 14 (PatternParens (C ([BlockComment ["A"]], [BlockComment ["B"]]) (at 1 7 1 8 Anything))) - , example "newlines" "(\n _\n )" $ at 2 2 2 3 Anything - ] - - , testGroup "tuple" - [ example "" "(x,y)" $ at 1 1 1 6 (TuplePattern [C ([], []) (at 1 2 1 3 (VarPattern (LowercaseIdentifier "x"))),C ([], []) (at 1 4 1 5 (VarPattern (LowercaseIdentifier "y")))]) - , example "whitespace" "( x , y )" $ at 1 1 1 10 (TuplePattern [C ([], []) (at 1 3 1 4 (VarPattern (LowercaseIdentifier "x"))),C ([], []) (at 1 7 1 8 (VarPattern (LowercaseIdentifier "y")))]) - , example "comments" "({-A-}x{-B-},{-C-}y{-D-})" $ at 1 1 1 26 (TuplePattern [C ([BlockComment ["A"]], [BlockComment ["B"]]) (at 1 7 1 8 (VarPattern (LowercaseIdentifier "x"))),C ([BlockComment ["C"]], [BlockComment ["D"]]) (at 1 19 1 20 (VarPattern (LowercaseIdentifier "y")))]) - , example "newlines" "(\n x\n ,\n y\n )" $ at 1 1 5 3 (TuplePattern [C ([], []) (at 2 2 2 3 (VarPattern (LowercaseIdentifier "x"))),C ([], []) (at 4 2 4 3 (VarPattern (LowercaseIdentifier "y")))]) - ] - - , testGroup "empty list pattern" - [ example "" "[]" $ at 1 1 1 3 (EmptyListPattern []) - , example "whitespace" "[ ]" $ at 1 1 1 4 (EmptyListPattern []) - , example "comments" "[{-A-}]" $ at 1 1 1 8 (EmptyListPattern [BlockComment ["A"]]) - , example "newlines" "[\n ]" $ at 1 1 2 3 (EmptyListPattern []) - ] - - , testGroup "list" - [ example "" "[x,y]" $ at 1 1 1 6 (ListPattern [C ([], []) (at 1 2 1 3 (VarPattern (LowercaseIdentifier "x"))),C ([], []) (at 1 4 1 5 (VarPattern (LowercaseIdentifier "y")))]) - , example "single element" "[x]" $ at 1 1 1 4 (ListPattern [C ([], []) (at 1 2 1 3 (VarPattern (LowercaseIdentifier "x")))]) - , example "whitespace" "[ x , y ]" $ at 1 1 1 10 (ListPattern [C ([], []) (at 1 3 1 4 (VarPattern (LowercaseIdentifier "x"))),C ([], []) (at 1 7 1 8 (VarPattern (LowercaseIdentifier "y")))]) - , example "comments" "[{-A-}x{-B-},{-C-}y{-D-}]" $ at 1 1 1 26 (ListPattern [C ([BlockComment ["A"]], [BlockComment ["B"]]) (at 1 7 1 8 (VarPattern (LowercaseIdentifier "x"))),C ([BlockComment ["C"]], [BlockComment ["D"]]) (at 1 19 1 20 (VarPattern (LowercaseIdentifier "y")))]) - , example "newlines" "[\n x\n ,\n y\n ]" $ at 1 1 5 3 (ListPattern [C ([], []) (at 2 2 2 3 (VarPattern (LowercaseIdentifier "x"))),C ([], []) (at 4 2 4 3 (VarPattern (LowercaseIdentifier "y")))]) - ] - - , testGroup "record" - [ example "" "{a,b}" $ at 1 1 1 6 (RecordPattern [C ([], []) (LowercaseIdentifier "a"),C ([], []) (LowercaseIdentifier "b")]) - , example "single element" "{a}" $ at 1 1 1 4 (RecordPattern [C ([], []) (LowercaseIdentifier "a")]) - , example "whitespace" "{ a , b }" $ at 1 1 1 10 (RecordPattern [C ([], []) (LowercaseIdentifier "a"),C ([], []) (LowercaseIdentifier "b")]) - , example "comments" "{{-A-}a{-B-},{-C-}b{-D-}}" $ at 1 1 1 26 (RecordPattern [C ([BlockComment ["A"]], [BlockComment ["B"]]) (LowercaseIdentifier "a"),C ([BlockComment ["C"]], [BlockComment ["D"]]) (LowercaseIdentifier "b")]) - , example "newlines" "{\n a\n ,\n b\n }" $ at 1 1 5 3 (RecordPattern [C ([], []) (LowercaseIdentifier "a"),C ([], []) (LowercaseIdentifier "b")]) - , example "empty" "{}" $ at 1 1 1 3 (EmptyRecordPattern []) - ] - - , testGroup "alias" - [ example "" "_ as x" $ at 1 1 1 7 (Alias (C [] (at 1 1 1 2 Anything)) (C [] (LowercaseIdentifier "x"))) - , example "left side has whitespace" "A b as x" $ at 1 1 1 9 $ Alias (C [] (at 1 1 1 4 $ DataPattern ([], UppercaseIdentifier "A") [C [] ( at 1 3 1 4 (VarPattern (LowercaseIdentifier "b")))])) (C [] (LowercaseIdentifier "x")) - , example "left side ctor without whitespace" "A as x" $ at 1 1 1 7 $ Alias (C [] (at 1 1 1 2 $ DataPattern ([], UppercaseIdentifier "A") [])) (C [] (LowercaseIdentifier "x")) - , example "comments" "_{-A-}as{-B-}x" $ at 1 1 1 15 (Alias (C [BlockComment ["A"]] (at 1 1 1 2 Anything)) (C [BlockComment ["B"]] (LowercaseIdentifier "x"))) - , example "newlines" "_\n as\n x" $ at 1 1 3 3 (Alias (C [] (at 1 1 1 2 Anything)) (C [] (LowercaseIdentifier "x"))) - , example "nested" "(_ as x)as y" $ at 1 1 1 13 (Alias (C [] (at 1 2 1 8 (Alias (C [] (at 1 2 1 3 Anything)) (C [] (LowercaseIdentifier "x"))))) (C [] (LowercaseIdentifier "y"))) - , example "nested (whitespace)" "(_ as x) as y" $ at 1 1 1 14 (Alias (C [] (at 1 2 1 8 (Alias (C [] (at 1 2 1 3 Anything)) (C [] (LowercaseIdentifier "x"))))) (C [] (LowercaseIdentifier "y"))) - , testCase "nesting required parentheses" $ - assertParseFailure (expr Elm_0_19) "_ as x as y" - ] - ] diff --git a/elm-format-lib/test/Parse/TestHelpers.hs b/elm-format-lib/test/Parse/TestHelpers.hs index 3d9616673..0a82837a6 100644 --- a/elm-format-lib/test/Parse/TestHelpers.hs +++ b/elm-format-lib/test/Parse/TestHelpers.hs @@ -2,8 +2,7 @@ module Parse.TestHelpers where import Elm.Utils ((|>)) -import Test.Tasty -import Test.Tasty.HUnit +import Test.Hspec import AST.V0_16 import AST.Structure @@ -23,28 +22,28 @@ parseFullInput parser = (\x _ -> x) <$> parser <*> eof -assertParse :: (Show a, Eq a) => IParser a -> String -> a -> Assertion +assertParse :: (Show a, Eq a) => IParser a -> String -> a -> Expectation assertParse parser input expected = let output = iParse (parseFullInput parser) input in case output of Left err -> - assertEqual (show err) False True + expectationFailure (show err) Right result -> - assertEqual input expected result + expected `shouldBe` result -assertParseFailure :: (Show a) => IParser a -> String -> Assertion +assertParseFailure :: (Show a) => IParser a -> String -> Expectation assertParseFailure parser input = let output = iParse (parseFullInput parser) input in case output of - Left err -> - assertEqual (show err) True True + Left _ -> + pure () Right result -> - assertEqual (show result) True False + expectationFailure ("Expected parse failure, but parsed: " <> show result) nowhere :: Region @@ -52,9 +51,9 @@ nowhere = A.Region (A.Position 0 0) (A.Position 0 0) at :: Word16 -> Word16 -> Word16 -> Word16 - -> AST (ns, UppercaseIdentifier) (ns, UppercaseIdentifier) (Ref ns) (ASTNS Located ns) kind - -> ASTNS Located ns kind -at a b c d = I.Fix . A.At (A.Region (A.Position a b) (A.Position c d)) + -> AST (VariableNamespace ns) (I.Fix2 Located (ASTNS ns)) kind + -> I.Fix2 Located (ASTNS ns) kind +at a b c d = I.Fix2 . A.At (A.Region (A.Position a b) (A.Position c d)) {-| Checks that removing indentation causes parsing to fail. @@ -62,12 +61,13 @@ at a b c d = I.Fix . A.At (A.Region (A.Position a b) (A.Position c d)) For each "\n " in the input string, a test case will be generated checking that the given parser will fail if that "\n " is replaced by "\n". -} -mustBeIndented :: Show a => IParser a -> [Char] -> TestTree +mustBeIndented :: Show a => IParser a -> [Char] -> SpecWith () mustBeIndented parser input = - input + describe "must be indented" $ do + input |> generateReplacements "\n " "\n" - |> List.map (testCase "" . assertParseFailure parser) - |> testGroup "must be indented" + |> List.map (it "" . assertParseFailure parser) + |> sequence_ generateReplacements :: (Eq a) => [a] -> [a] -> [a] -> [[a]] diff --git a/elm-format-lib/test/Parse/TestHelpersSpec.hs b/elm-format-lib/test/Parse/TestHelpersSpec.hs new file mode 100644 index 000000000..458e1b78e --- /dev/null +++ b/elm-format-lib/test/Parse/TestHelpersSpec.hs @@ -0,0 +1,19 @@ +module Parse.TestHelpersSpec where + +import Test.Hspec + +import Parse.TestHelpers + + +spec :: Spec +spec = describe "TestHelpers" $ do + describe "generateReplacements" $ do + it "empty" $ + generateReplacements "a" "b" "" + `shouldBe` [] + it "single match" $ + generateReplacements "a" "b" "1a2" + `shouldBe` ["1b2"] + it "multiple matches" $ + generateReplacements "a" "b" "a1a2a3a" + `shouldBe`["b1a2a3a", "a1b2a3a", "a1a2b3a", "a1a2a3b"] diff --git a/elm-format-lib/test/Parse/TestHelpersTest.hs b/elm-format-lib/test/Parse/TestHelpersTest.hs deleted file mode 100644 index 28dd51cf7..000000000 --- a/elm-format-lib/test/Parse/TestHelpersTest.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Parse.TestHelpersTest where - -import Test.Tasty -import Test.Tasty.HUnit - -import Parse.TestHelpers - - - -test_tests :: TestTree -test_tests = - testGroup "TestHelpers" - [ testGroup "generateReplacements" - [ testCase "empty" $ - assertEqual "" [] $ generateReplacements "a" "b" "" - , testCase "single match" $ - assertEqual "" ["1b2"] $ generateReplacements "a" "b" "1a2" - , testCase "multiple matches" $ - assertEqual "" ["b1a2a3a", "a1b2a3a", "a1a2b3a", "a1a2a3b"] $ generateReplacements "a" "b" "a1a2a3a" - ] - ] diff --git a/elm-format-lib/test/Parse/TypeTest.hs b/elm-format-lib/test/Parse/TypeSpec.hs similarity index 56% rename from elm-format-lib/test/Parse/TypeTest.hs rename to elm-format-lib/test/Parse/TypeSpec.hs index e6c8685b7..246ee29c9 100644 --- a/elm-format-lib/test/Parse/TypeTest.hs +++ b/elm-format-lib/test/Parse/TypeSpec.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DataKinds #-} -module Parse.TypeTest where +module Parse.TypeSpec where -import Test.Tasty -import Test.Tasty.HUnit +import Test.Hspec hiding (example) import qualified Parse.Type import AST.V0_16 @@ -15,47 +13,45 @@ import qualified Box import qualified Data.Text as Text import Parse.IParser import Reporting.Annotation (Located) +import qualified Data.Fix as Fix +import qualified ElmFormat.Render.ElmStructure as ElmStructure +import qualified Data.Indexed as I +import Data.Coapplicative (extract) -pending :: ASTNS Located ns 'TypeNK -pending = at 0 0 0 0 $ TupleType [] (ForceMultiline False) - -expr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'TypeNK) +expr :: ElmVersion -> IParser (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'TypeNK) expr = Parse.Type.expr -example :: String -> String -> String -> TestTree +example :: String -> String -> String -> SpecWith () example name input expected = - testCase name $ - assertParse (fmap (Text.unpack . Box.render . typeParens NotRequired . formatType Elm_0_19) (expr Elm_0_19)) input expected + it name $ + assertParse (fmap (Text.unpack . Box.render . Fix.cata ElmStructure.render . typeParens NotRequired . formatType Elm_0_19 . I.fold2 (I.Fix . extract)) (expr Elm_0_19)) input expected -test_tests :: TestTree -test_tests = - testGroup "Parse.Type" - [ testGroup "tuple type" - [ example "" "(a,b)" "( a, b )\n" - , example "whitespace" "( a , b )" "( a, b )\n" - , example "comments" +spec :: Spec +spec = describe "Parse.Type" $ do + describe "tuple type" $ do + example "" "(a,b)" "( a, b )\n" + example "whitespace" "( a , b )" "( a, b )\n" + example "comments" "({-A-}a{-B-},{-C-}b{-D-})" "( {- A -} a {- B -}, {- C -} b {- D -} )\n" - , example "newlines" "(\n a\n ,\n b\n )" "( a\n, b\n)\n" - ] + example "newlines" "(\n a\n ,\n b\n )" "( a\n, b\n)\n" - , testGroup "record type" - [ testGroup "empty" - [ example "" "{}" "{}\n" - , example "whitespace" "{ }" "{}\n" - , example "comments" "{{-A-}}" "{{- A -}}\n" - ] + describe "record type" $ do + describe "empty" $ do + example "" "{}" "{}\n" + example "whitespace" "{ }" "{}\n" + example "comments" "{{-A-}}" "{{- A -}}\n" - , example "" + example "" "{x:m,y:n}" "{ x : m, y : n }\n" - , example "whitespace" + example "whitespace" "{ x : m , y : n }" "{ x : m, y : n }\n" - , example "comments" + example "comments" "{{-A-}x{-B-}:{-C-}m{-D-},{-E-}y{-F-}:{-G-}n{-H-}}" "{ {- A -} x {- B -} : {- C -} m\n\ \\n\ @@ -64,32 +60,31 @@ test_tests = \\n\ \{- H -}\n\ \}\n" - , example "single field with comments" + example "single field with comments" "{{-A-}x{-B-}:{-C-}m{-D-}}" "{ {- A -} x {- B -} : {- C -} m\n\ \\n\ \{- D -}\n\ \}\n" - , example "newlines" + example "newlines" "{\n x\n :\n m\n ,\n y\n :\n n\n }" "{ x :\n\ \ m\n\ \, y :\n\ \ n\n\ \}\n" - ] - , testGroup "record extension type" - [ example "" + describe "record extension type" $ do + example "" "{a|x:m,y:n}" "{ a | x : m, y : n }\n" - , example "single field" + example "single field" "{a|x:m}" "{ a | x : m }\n" - , example "whitespace" + example "whitespace" "{ a | x : m , y : n }" "{ a | x : m, y : n }\n" - , example "comments" + example "comments" "{{-A-}a{-B-}|{-C-}x{-D-}:{-E-}m{-F-},{-G-}y{-H-}:{-I-}n{-J-}}" "{ {- A -} a {- B -}\n\ \ | {- C -} x {- D -} : {- E -} m\n\ @@ -99,7 +94,7 @@ test_tests = \\n\ \ {- J -}\n\ \}\n" - , example "newlines" + example "newlines" "{\n a\n |\n x\n :\n m\n ,\n y\n :\n n\n }" "{ a\n\ \ | x :\n\ @@ -107,12 +102,10 @@ test_tests = \ , y :\n\ \ n\n\ \}\n" - , testCase "only allows simple base" $ + it "only allows simple base" $ assertParseFailure (expr Elm_0_19) "{()|x:m}" - , testCase "only allows simple base" $ + it "only allows simple base" $ assertParseFailure (expr Elm_0_19) "{{}|x:m}" - , example "no fields (elm-compiler does not allow this)" + example "no fields (elm-compiler does not allow this)" "{a|}" - "{ a | }\n" - ] - ] + "{ a | }\n" diff --git a/elm-format-lib/test/Spec.hs b/elm-format-lib/test/Spec.hs new file mode 100644 index 000000000..a824f8c30 --- /dev/null +++ b/elm-format-lib/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/elm-format-lib/test/Tests.hs b/elm-format-lib/test/Tests.hs deleted file mode 100644 index 70c55f52f..000000000 --- a/elm-format-lib/test/Tests.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/elm-format-markdown/elm-format-markdown.cabal b/elm-format-markdown/elm-format-markdown.cabal index c58ca89d2..562a9e5e2 100644 --- a/elm-format-markdown/elm-format-markdown.cabal +++ b/elm-format-markdown/elm-format-markdown.cabal @@ -17,18 +17,34 @@ build-type: Simple common common-options - - ghc-options: - -O2 -Wall -Wno-name-shadowing - default-language: Haskell2010 + ghc-options: + -O2 + -Wall + -Wcompat + -Wredundant-constraints + -Wno-name-shadowing + -Werror=inaccessible-code + -Werror=missing-home-modules + -Werror=overflowed-literals + -Werror=overlapping-patterns default-extensions: + ApplicativeDo + DataKinds + DeriveFoldable DeriveFunctor - MultiParamTypeClasses + DeriveTraversable + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving LambdaCase + MultiParamTypeClasses OverloadedStrings + PolyKinds ScopedTypeVariables + TypeApplications + TypeFamilies hs-source-dirs: . diff --git a/elm-format-test-lib/elm-format-test-lib.cabal b/elm-format-test-lib/elm-format-test-lib.cabal index 8a3c31eb2..ae5b1ac69 100644 --- a/elm-format-test-lib/elm-format-test-lib.cabal +++ b/elm-format-test-lib/elm-format-test-lib.cabal @@ -17,33 +17,48 @@ build-type: Simple common common-options - ghc-options: - -O2 -Wall -Wno-name-shadowing - default-language: Haskell2010 - + ghc-options: + -O2 + -Wall + -Wcompat + -Wredundant-constraints + -Wno-name-shadowing + -Werror=inaccessible-code + -Werror=missing-home-modules + -Werror=overflowed-literals + -Werror=overlapping-patterns default-extensions: + ApplicativeDo + DataKinds + DeriveFoldable DeriveFunctor + DeriveTraversable + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving LambdaCase + MultiParamTypeClasses OverloadedStrings + PolyKinds ScopedTypeVariables + TypeApplications + TypeFamilies hs-source-dirs: src other-modules: - TestWorld.Stdio build-depends: base >= 4.15.0.0 && < 5, containers >= 0.6.5.1 && < 0.7, filepath >= 1.4.2.1 && < 1.5, - hspec-core >= 2.7.4 && < 3, + hspec >= 2.7.10 && < 3, + hspec-core >= 2.7.10 && < 3, hspec-golden >= 0.1.0.3 && < 0.2, + microlens-platform >= 0.4.2.1 && < 0.5, mtl >= 2.2.2 && < 3, split >= 0.2.3.4 && < 0.3, - tasty >= 1.2 && < 2, - tasty-hspec >= 1.1.5.1 && < 1.2, - tasty-hunit >= 0.10.0.1 && < 0.11, text >= 1.2.5.0 && < 2, avh4-lib @@ -54,7 +69,7 @@ library exposed-modules: CommandLine.TestWorld Data.FileTree - Expect + TestWorld.Stdio test-suite elm-format-test-lib-tests @@ -62,12 +77,12 @@ test-suite elm-format-test-lib-tests type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: Tests.hs + main-is: Spec.hs other-modules: Data.FileTree - Data.FileTreeTest - Expect + Data.FileTreeSpec + TestWorld.Stdio build-tool-depends: - tasty-discover:tasty-discover >= 4.2.1 && < 5 + hspec-discover:hspec-discover >= 2.7.10 && < 3 diff --git a/elm-format-test-lib/src/CommandLine/TestWorld.hs b/elm-format-test-lib/src/CommandLine/TestWorld.hs index 3c0306d8b..418bd6427 100644 --- a/elm-format-test-lib/src/CommandLine/TestWorld.hs +++ b/elm-format-test-lib/src/CommandLine/TestWorld.hs @@ -1,9 +1,5 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module CommandLine.TestWorld (TestWorldState, TestWorld, lastExitCode, init,uploadFile, downloadFile, eval,queueStdin,fullStdout,golden,fullStderr,expectExit,expectFileContents,goldenExitStdout) where +module CommandLine.TestWorld (TestWorldState, TestWorld, lastExitCode, init,uploadFile, downloadFile, eval,queueStdin,fullStdout,golden,fullStderr,expectExit,expectFileContents,goldenExitStdout, testWorld) where import Prelude hiding (putStr, putStrLn, readFile, writeFile, init) import CommandLine.World @@ -18,13 +14,13 @@ import Control.Monad.Identity (Identity) import Test.Hspec.Golden ( Golden(..) ) import qualified Data.Text.IO import Test.Hspec.Core.Spec (Example(..), Result(..), ResultStatus(..)) -import Test.Tasty.Hspec (shouldBe, Expectation) +import Test.Hspec (shouldBe, Expectation) data TestWorldState = TestWorldState { filesystem :: FileTree Text - , stdio :: Stdio.State + , stdio :: Stdio.Stdio , _lastExitCode :: LastExitCode } @@ -80,7 +76,7 @@ instance Lens TestWorldState (FileTree Text) where get = filesystem set x s = s { filesystem = x } -instance Lens TestWorldState Stdio.State where +instance Lens TestWorldState Stdio.Stdio where get = stdio set x s = s { stdio = x } @@ -110,8 +106,7 @@ instance Monad m => World (State.StateT TestWorldState m) where putStr = modify . Stdio.putStr putStrLn = modify . Stdio.putStrLn - writeStdout text = - putStr text + writeStdout = putStr putStrStderr = modify . Stdio.putStrStderr putStrLnStderr = modify . Stdio.putStrLnStderr @@ -143,7 +138,7 @@ eval = State.evalState queueStdin :: Text -> TestWorld () queueStdin = - modify' (undefined :: Stdio.State) . over . Stdio.queueStdin + modify' (undefined :: Stdio.Stdio) . over . Stdio.queueStdin init :: TestWorldState @@ -162,12 +157,12 @@ downloadFile = fullStdout :: TestWorld Text fullStdout = - gets' (undefined :: Stdio.State) $ from Stdio.fullStdout + gets' (undefined :: Stdio.Stdio) $ from Stdio.fullStdout fullStderr :: TestWorld Text fullStderr = - gets' (undefined :: Stdio.State) $ from Stdio.fullStderr + gets' (undefined :: Stdio.Stdio) $ from Stdio.fullStderr lastExitCode :: TestWorld (Maybe Int) diff --git a/elm-format-test-lib/src/Expect.hs b/elm-format-test-lib/src/Expect.hs deleted file mode 100644 index d948f6c20..000000000 --- a/elm-format-test-lib/src/Expect.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Expect where - -import Test.Tasty.HUnit ((@=?)) - - -equals :: (Eq a, Show a) => a -> a -> IO () -equals expected actual = - expected @=? actual diff --git a/elm-format-test-lib/src/TestWorld/Stdio.hs b/elm-format-test-lib/src/TestWorld/Stdio.hs index 1b160095c..e1a22dd66 100644 --- a/elm-format-test-lib/src/TestWorld/Stdio.hs +++ b/elm-format-test-lib/src/TestWorld/Stdio.hs @@ -1,58 +1,73 @@ -module TestWorld.Stdio (State, empty, fullStdout,fullStderr,getStdin,putStr,putStrLn,putStrStderr,putStrLnStderr,queueStdin) where +{-# LANGUAGE TemplateHaskell #-} + +module TestWorld.Stdio (Stdio, empty, fullStdout,fullStderr,getStdin,putStr,putStrLn,putStrStderr,putStrLnStderr,queueStdin) where import Prelude hiding (putStr, putStrLn) import Data.Text (Text) +import Lens.Micro.Platform (makeLenses, (^.)) +import qualified Data.Text as Text -data State = - State +data Stdio = + Stdio { _queuedStdin :: Text , _stdout :: [Text] , _stderr :: [Text] } +makeLenses ''Stdio + +instance Show Stdio where + show stdio = Text.unpack $ mconcat + [ "Queued stdin:\n" + , stdio ^. queuedStdin + , "\nStdout:\n" + , Text.intercalate "\n" $ stdio ^. stdout + , "\nStderr:\n" + , Text.intercalate "\n" $ stdio ^. stderr + ] -empty :: State -empty = State "" [] [] +empty :: Stdio +empty = Stdio "" [] [] -fullStdout :: State -> Text +fullStdout :: Stdio -> Text fullStdout = mconcat . reverse . _stdout -fullStderr :: State -> Text +fullStderr :: Stdio -> Text fullStderr = mconcat . reverse . _stderr -getStdin :: State -> (Text, State) +getStdin :: Stdio -> (Text, Stdio) getStdin state = ( _queuedStdin state , state { _queuedStdin = "" } ) -putStr :: Text -> State -> State +putStr :: Text -> Stdio -> Stdio putStr text state = state { _stdout = text : _stdout state} -putStrLn :: Text -> State -> State +putStrLn :: Text -> Stdio -> Stdio putStrLn line = putStr (line <> "\n") -putStrStderr :: Text -> State -> State +putStrStderr :: Text -> Stdio -> Stdio putStrStderr text state = state { _stderr = text : _stderr state } -putStrLnStderr :: Text -> State -> State +putStrLnStderr :: Text -> Stdio -> Stdio putStrLnStderr line = putStrStderr (line <> "\n") -queueStdin :: Text -> State -> State +queueStdin :: Text -> Stdio -> Stdio queueStdin newStdin state = state { _queuedStdin = newStdin } diff --git a/elm-format-test-lib/test/Data/FileTreeTest.hs b/elm-format-test-lib/test/Data/FileTreeSpec.hs similarity index 97% rename from elm-format-test-lib/test/Data/FileTreeTest.hs rename to elm-format-test-lib/test/Data/FileTreeSpec.hs index b77c76974..b96336a1a 100644 --- a/elm-format-test-lib/test/Data/FileTreeTest.hs +++ b/elm-format-test-lib/test/Data/FileTreeSpec.hs @@ -1,15 +1,15 @@ -module Data.FileTreeTest where +module Data.FileTreeSpec where import Elm.Utils ((|>)) import Data.FileTree (FileTree) import qualified Data.FileTree as FileTree import Data.Text (Text) -import Test.Tasty.Hspec +import Test.Hspec import System.FilePath (pathSeparator) -spec_spec :: Spec -spec_spec = +spec :: Spec +spec = describe "Data.FileTree" $ do it "can read and write a file" $ do (mempty :: FileTree Text) diff --git a/elm-format-test-lib/test/Spec.hs b/elm-format-test-lib/test/Spec.hs new file mode 100644 index 000000000..a824f8c30 --- /dev/null +++ b/elm-format-test-lib/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/elm-format-test-lib/test/Tests.hs b/elm-format-test-lib/test/Tests.hs deleted file mode 100644 index 70c55f52f..000000000 --- a/elm-format-test-lib/test/Tests.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/elm-format.cabal b/elm-format.cabal index 014c5128d..1c32de1f4 100644 --- a/elm-format.cabal +++ b/elm-format.cabal @@ -33,12 +33,32 @@ source-repository head common common-options default-language: Haskell2010 ghc-options: - -threaded -O2 -Wall -Wno-name-shadowing + -threaded + -O2 + -Wall + -Wcompat + -Wredundant-constraints + -Wno-name-shadowing + -Werror=inaccessible-code + -Werror=missing-home-modules + -Werror=overflowed-literals + -Werror=overlapping-patterns default-extensions: + ApplicativeDo + DataKinds + DeriveFoldable DeriveFunctor + DeriveTraversable + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving LambdaCase + MultiParamTypeClasses OverloadedStrings + PolyKinds ScopedTypeVariables + TypeApplications + TypeFamilies hs-source-dirs: src @@ -52,10 +72,10 @@ common common-options ElmFormat.Version build-depends: - aeson >= 2.0.1.0 && < 2.1, + aeson >= 2.0.3.0 && < 2.1, ansi-wl-pprint >= 0.6.9 && < 0.7, base >= 4.15.0.0 && < 5, - bytestring >= 0.11.1.0 && < 0.12, + bytestring >= 0.10.12.1 && < 0.12, containers >= 0.6.5.1 && < 0.7, optparse-applicative >= 0.16.1.0 && < 0.17, relude >= 1.0.0.1 && < 1.1, @@ -74,22 +94,19 @@ test-Suite elm-format-tests type: exitcode-stdio-1.0 hs-source-dirs: tests - main-is: Test.hs + main-is: Spec.hs other-modules: CommonMarkTests - Integration.CliTest - Integration.LiteralTest + Integration.CliSpec + Integration.LiteralSpec Test.ElmSourceGenerators Test.Generators Test.Property build-depends: mtl >= 2.2.2 && < 3, - tasty >= 1.2 && < 2, - tasty-hspec >= 1.1.5.1 && < 1.2, - tasty-hunit >= 0.10.0.1 && < 0.11, - tasty-quickcheck >= 0.10.1 && < 0.11, + hspec >= 2.7.10 && < 3, QuickCheck >= 2.12.6.1 && < 3, quickcheck-io >= 0.2.0 && < 0.3, bimap >= 0.4.0 && < 0.5, diff --git a/src/ElmFormat/Cli.hs b/src/ElmFormat/Cli.hs index c6f39a902..b746d4528 100644 --- a/src/ElmFormat/Cli.hs +++ b/src/ElmFormat/Cli.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE DataKinds #-} module ElmFormat.Cli (main, main') where import Prelude () import Relude hiding (exitFailure, exitSuccess, putStr, putStrLn) -import AST.Module (Module) import AST.Structure import AST.V0_16 import CommandLine.Program (ProgramIO) @@ -27,6 +25,8 @@ import qualified ElmFormat.AST.PublicAST as PublicAST import qualified Data.Aeson as Aeson import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB +import qualified Data.Indexed as I +import Data.Coapplicative (extract) data WhatToDo @@ -157,7 +157,7 @@ validate :: ElmVersion -> (FilePath, Text.Text) -> Either InfoMessage () validate elmVersion input@(inputFile, inputText) = case parseModule elmVersion input of Right modu -> - if inputText /= Render.render elmVersion modu then + if inputText /= Render.render elmVersion (I.fold2 (I.Fix . extract) modu) then Left $ FileWouldChange elmVersion inputFile else Right () @@ -169,7 +169,7 @@ validate elmVersion input@(inputFile, inputText) = parseModule :: ElmVersion -> (FilePath, Text.Text) - -> Either InfoMessage (Module [UppercaseIdentifier] (ASTNS Located [UppercaseIdentifier] 'TopLevelNK)) + -> Either InfoMessage (I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ModuleNK) parseModule elmVersion (inputFile, inputText) = case Parse.parse elmVersion inputText of Result.Result _ (Result.Ok modu) -> @@ -180,7 +180,7 @@ parseModule elmVersion (inputFile, inputText) = parseJson :: (FilePath, Text.Text) - -> Either InfoMessage (Module [UppercaseIdentifier] (ASTNS Identity [UppercaseIdentifier] 'TopLevelNK)) + -> Either InfoMessage (I.Fix (ASTNS [UppercaseIdentifier]) 'ModuleNK) parseJson (inputFile, inputText) = case Aeson.eitherDecode (LB.fromChunks . return . encodeUtf8 $ inputText) of Right modu -> Right $ PublicAST.toModule modu @@ -191,7 +191,7 @@ parseJson (inputFile, inputText) = format :: ElmVersion -> (FilePath, Text.Text) -> Either InfoMessage Text.Text format elmVersion input = - Render.render elmVersion <$> parseModule elmVersion input + Render.render elmVersion . I.fold2 (I.Fix . extract) <$> parseModule elmVersion input toJson :: ElmVersion -> (FilePath, Text.Text) -> Either InfoMessage Text.Text diff --git a/tests/CommonMarkTests.hs b/tests/CommonMarkTests.hs index d084b9d49..c365f7b68 100644 --- a/tests/CommonMarkTests.hs +++ b/tests/CommonMarkTests.hs @@ -2,8 +2,7 @@ module CommonMarkTests (construct) where import qualified CMark import Prelude hiding (init) -import Test.Tasty -import Test.Tasty.HUnit +import Test.Hspec hiding (example) import qualified Data.Text as Strict import qualified Data.Text.Lazy as Text import qualified Data.Text.Lazy.IO as TextIO @@ -19,8 +18,8 @@ data ParseState = ParseState , input :: [String] , output :: [String] , state :: State - , siblings :: [TestTree] - , children :: [TestTree] + , siblings :: [Spec] + , children :: [Spec] , example :: Int } @@ -49,7 +48,7 @@ step (ParseState path input output state siblings children example) line = , siblings = if null children then siblings - else testGroup path (reverse children) : siblings + else describe path (sequence_ $ reverse children) : siblings , children = [] , example = example } @@ -115,13 +114,13 @@ step (ParseState path input output state siblings children example) line = } -done :: ParseState -> [TestTree] +done :: ParseState -> [Spec] done (ParseState path input output state siblings children _) = -- validate parse finished cleanly? - reverse $ testGroup path children : siblings + reverse $ describe path (sequence_ children) : siblings -makeTest :: Int -> String -> String -> String -> TestTree +makeTest :: Int -> String -> String -> String -> Spec makeTest i name input output = let source = Strict.map (\c -> if c == '→' then '\t' else c) $ Strict.pack $ input @@ -129,22 +128,16 @@ makeTest i name input output = formatted = ElmFormat.Render.Markdown.formatMarkdown (const Nothing) (Parse.Markdown.parse $ Strict.unpack source) -- specOutput = Strict.map (\c -> if c == '→' then '\t' else c) $ Strict.pack output - - description = "formatted markdown should render the same as the original\n\n" - ++ Strict.unpack source - ++ "\n" - ++ formatted in - testCase ("Example " ++ show i ++ ": " ++ name) $ - assertEqual description - (CMark.commonmarkToHtml [] $ source) - (CMark.commonmarkToHtml [] $ Strict.pack formatted) + it ("Example " ++ show i ++ ": " ++ name) $ + CMark.commonmarkToHtml [] (Strict.pack formatted) + `shouldBe` CMark.commonmarkToHtml [] source -construct :: IO TestTree +construct :: IO Spec construct = do spec <- TextIO.readFile "tests/test-files/CommonMark/spec.txt" return $ - testGroup "CommonMark" $ - done $ foldl step init (Text.lines spec) + describe "CommonMark" $ + sequence_ $ done $ foldl step init (Text.lines spec) diff --git a/tests/Integration/CliTest.hs b/tests/Integration/CliSpec.hs similarity index 97% rename from tests/Integration/CliTest.hs rename to tests/Integration/CliSpec.hs index 36c2c1677..cf65b886c 100644 --- a/tests/Integration/CliTest.hs +++ b/tests/Integration/CliSpec.hs @@ -1,14 +1,14 @@ -module Integration.CliTest (spec_spec) where +module Integration.CliSpec (spec) where import CommandLine.TestWorld -import Test.Tasty.Hspec hiding (Success) +import Test.Hspec import qualified ElmFormat.Cli as ElmFormat import Data.Text (Text) import qualified Data.Text as Text -spec_spec :: Spec -spec_spec = +spec :: Spec +spec = describe "CLI" $ do it "usage" $ do ElmFormat.main [ "--help" ] diff --git a/tests/Integration/LiteralTest.hs b/tests/Integration/LiteralSpec.hs similarity index 78% rename from tests/Integration/LiteralTest.hs rename to tests/Integration/LiteralSpec.hs index 417da5f7d..7958585b3 100644 --- a/tests/Integration/LiteralTest.hs +++ b/tests/Integration/LiteralSpec.hs @@ -1,8 +1,7 @@ -module Integration.LiteralTest (tests) where +module Integration.LiteralSpec (spec) where import Elm.Utils ((|>)) -import Test.Tasty -import Test.Tasty.HUnit +import Test.Hspec import qualified Data.Text as Text import qualified ElmFormat.Parse as Parse @@ -10,10 +9,9 @@ import qualified ElmFormat.Render.Text as Render import qualified ElmVersion import qualified Reporting.Error.Syntax -tests :: TestTree -tests = - testGroup "Literals" $ - map makeTest +spec :: Spec +spec = describe "Literals" $ + mapM_ makeTest [ -- Booleans -- ("True", "True\n") -- , ("False", "False\n") @@ -46,12 +44,11 @@ tests = ] -makeTest :: (String, String) -> TestTree +makeTest :: (String, String) -> SpecWith (Arg Expectation) makeTest (original, formatted) = - testCase original $ - assertEqual "formatting should match" - (Right $ Text.pack formatted) - (format original) + it original $ + Right (Text.pack formatted) + `shouldBe` format original format :: String -> Either [Reporting.Error.Syntax.Error] Text.Text diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 index 000000000..5debe6779 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,19 @@ +module Main where + +import Test.Hspec + +import qualified Test.Property +-- import qualified CommonMarkTests +import qualified Integration.CliSpec +import qualified Integration.LiteralSpec + + +main :: IO () +main = + do + -- markdownTests <- CommonMarkTests.construct + hspec $ describe "elm-format" $ do + Test.Property.propertyTests + Integration.CliSpec.spec + Integration.LiteralSpec.spec + -- markdownTests diff --git a/tests/Test.hs b/tests/Test.hs deleted file mode 100644 index 0c74d9345..000000000 --- a/tests/Test.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Main where - -import Test.Tasty -import Test.Tasty.Hspec (testSpec) - -import qualified Test.Property --- import qualified CommonMarkTests -import qualified Integration.CliTest -import qualified Integration.LiteralTest - - -main :: IO () -main = - do - -- markdownTests <- CommonMarkTests.construct - spec <- testSpec "" Integration.CliTest.spec_spec - defaultMain $ testGroup "elm-format" $ - [ Test.Property.propertyTests - , spec - , Integration.LiteralTest.tests - -- , markdownTests - ] diff --git a/tests/Test/Generators.hs b/tests/Test/Generators.hs index 18b70a809..788592957 100644 --- a/tests/Test/Generators.hs +++ b/tests/Test/Generators.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Test.Generators where @@ -8,13 +6,9 @@ import Data.Map.Strict import Test.QuickCheck import AST.V0_16 -import AST.Module (Module) -import qualified AST.Module import AST.Structure -import qualified AST.Listing import Data.Functor.Identity import qualified Data.Indexed as I -import qualified Reporting.Annotation capitalLetter :: Gen Char @@ -59,32 +53,35 @@ commented inner = C ([], []) <$> inner -instance Arbitrary AST.Listing.Value where +instance Arbitrary ListingValue where arbitrary = do name <- capIdentifier - return $ AST.Listing.Union (C [] name) AST.Listing.ClosedListing + return $ Union (C [] name) ClosedListing -listing :: Gen (AST.Listing.Listing a) +listing :: Gen (Listing a) listing = - return $ AST.Listing.OpenListing (C ([], []) ()) + return $ OpenListing (C ([], []) ()) -instance Arbitrary (Module [UppercaseIdentifier] (ASTNS Identity [UppercaseIdentifier] 'TopLevelNK)) where +instance Arbitrary (I.Fix2 Identity (ASTNS [UppercaseIdentifier]) 'ModuleNK) where arbitrary = do - name <- listOf1 $ capIdentifier + name <- listOf1 capIdentifier listing <- listing - moduleType <- fmap (\x -> if x then AST.Module.Port [] else AST.Module.Normal) arbitrary - return $ AST.Module.Module + moduleType <- fmap (\x -> if x then Port [] else Normal) arbitrary + let body = I.Fix2 $ pure $ ModuleBody + [ Entry $ I.Fix2 $ pure $ CommonDeclaration $ I.Fix2 $ pure $ Definition (I.Fix2 $ pure $ Anything) [] [] (I.Fix2 $ pure $ TupleFunction 2) + ] + return $ I.Fix2 $ pure $ Module [] - (Just $ AST.Module.Header + (Just $ I.Fix2 $ pure $ ModuleHeader moduleType (C ([], []) name) Nothing - (Just $ C ([], []) listing) + (Just $ C ([], []) $ I.Fix2 $ pure $ ModuleListing listing) ) - (Reporting.Annotation.at (Reporting.Annotation.Position 0 0) (Reporting.Annotation.Position 0 0) Nothing) + Nothing (C [] empty) - (I.Fix $ pure $ TopLevel [ Entry $ I.Fix $ pure $ CommonDeclaration $ I.Fix $ pure $ Definition (I.Fix $ pure $ Anything) [] [] (I.Fix $ pure $ TupleFunction 2)]) + body diff --git a/tests/Test/Property.hs b/tests/Test/Property.hs index 5200ff7d8..8f85c68ea 100644 --- a/tests/Test/Property.hs +++ b/tests/Test/Property.hs @@ -1,15 +1,12 @@ -{-# LANGUAGE DataKinds #-} module Test.Property where import Prelude hiding ((>>)) import Elm.Utils ((|>), (>>)) import AST.V0_16 -import AST.Module (Module) import AST.Structure -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck +import Test.Hspec +import Test.Hspec.QuickCheck import Test.QuickCheck.IO () import Reporting.Annotation (Located) @@ -20,9 +17,12 @@ import qualified ElmFormat.Render.Text as Render import qualified ElmVersion import qualified Test.Generators () import qualified Test.ElmSourceGenerators +import qualified Data.Indexed as I +import Data.Coapplicative (extract) +import Test.QuickCheck (Property, Testable, counterexample, forAll) -assertStringToString :: String -> Assertion +assertStringToString :: String -> Expectation assertStringToString source = let source' = Text.pack source @@ -30,28 +30,32 @@ assertStringToString source = result = Parse.parse ElmVersion.Elm_0_19 source' |> Parse.toEither + |> fmap (I.fold2 $ I.Fix . extract) |> fmap (Render.render ElmVersion.Elm_0_19) in - assertEqual "" (Right source') result + result `shouldBe` Right source' -astToAst :: Module [UppercaseIdentifier] (ASTNS Located [UppercaseIdentifier] 'TopLevelNK) -> Assertion +astToAst :: I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ModuleNK -> Expectation astToAst ast = let result = ast + |> I.fold2 (I.Fix . extract) |> Render.render ElmVersion.Elm_0_19 |> Parse.parse ElmVersion.Elm_0_19 |> Parse.toEither in - assertEqual "" (Right ast) result + result `shouldBe` Right ast +simpleAst :: I.Fix2 Located (ASTNS [UppercaseIdentifier]) 'ModuleNK simpleAst = case Parse.toEither $ Parse.parse ElmVersion.Elm_0_19 $ Text.pack "module Main exposing (foo)\n\n\nfoo =\n 8\n" of Right ast -> ast +reportFailedAst :: I.Fix (ASTNS [UppercaseIdentifier]) 'ModuleNK -> [Char] reportFailedAst ast = let rendering = Render.render ElmVersion.Elm_0_19 ast |> Text.unpack @@ -69,34 +73,32 @@ reportFailedAst ast = , "=== END OF failed AST rendering\n" ] -withCounterexample fn prop = - (\s -> counterexample (fn s) $ prop s) +withCounterexample :: Testable prop => (t -> String) -> (t -> prop) -> t -> Property +withCounterexample fn prop s = + counterexample (fn s) $ prop s -propertyTests :: TestTree +propertyTests :: Spec propertyTests = - testGroup "example test group" -- [ testCase "simple AST round trip" $ -- astToAst simpleAst -- , testProperty "rendered AST should parse as equivalent AST" -- $ withCounterexample reportFailedAst astToAst - [ testGroup "valid Elm files" - [ testProperty "should parse" - $ forAll Test.ElmSourceGenerators.elmModule $ withCounterexample id - $ Text.pack >> Parse.parse ElmVersion.Elm_0_19 >> Parse.toMaybe >> Maybe.isJust + describe "valid Elm files" $ do + prop "should parse" $ + forAll Test.ElmSourceGenerators.elmModule $ withCounterexample id $ + Text.pack >> Parse.parse ElmVersion.Elm_0_19 >> Parse.toMaybe >> Maybe.isJust - -- , testProperty "should parse to the same AST after formatting" + -- testProperty "should parse to the same AST after formatting" -- $ forAll Test.ElmSourceGenerators.elmModule $ withCounterexample id -- $ Text.pack >> Parse.parse ElmVersion.Elm_0_19 >> Parse.toMaybe -- >> fmap astToAst -- >> Maybe.fromMaybe (assertFailure "failed to parse original") - ] - - , testCase "simple round trip" $ - assertStringToString "module Main exposing (foo)\n\n\nfoo =\n 8\n" - , testCase "simple round trip with comments" $ - assertStringToString "module Main exposing (foo)\n\n\nfoo =\n ( {- A -} 3 {- B -}, {- C -} 4 {- D -} )\n" - , testCase "simple round trip with comments" $ - assertStringToString "module Main exposing (commentedLiterals)\n\n\ncommentedLiterals =\n ( {- int -} 1, {- float -} 0.1, {- char -} \'c\', {- string -} \"str\", {- boolean -} True )\n" - ] + + it "simple round trip" $ + assertStringToString "module Main exposing (foo)\n\n\nfoo =\n 8\n" + it "simple round trip with comments" $ + assertStringToString "module Main exposing (foo)\n\n\nfoo =\n ( {- A -} 3 {- B -}, {- C -} 4 {- D -} )\n" + it "simple round trip with comments" $ + assertStringToString "module Main exposing (commentedLiterals)\n\n\ncommentedLiterals =\n ( {- int -} 1, {- float -} 0.1, {- char -} \'c\', {- string -} \"str\", {- boolean -} True )\n" diff --git a/tests/test-files/good/Elm-0.18/mdgriffith/style-elements/Element.elm b/tests/test-files/good/Elm-0.18/mdgriffith/style-elements/Element.elm index ae71cb898..6efb2519b 100644 --- a/tests/test-files/good/Elm-0.18/mdgriffith/style-elements/Element.elm +++ b/tests/test-files/good/Elm-0.18/mdgriffith/style-elements/Element.elm @@ -16,6 +16,7 @@ module Element exposing , bold, italic, strike, underline, sub, super , Device, classifyDevice, responsive , toHtml, embedStylesheet + -- , numbered -- , bulleted ) diff --git a/tests/test-files/transform/Elm-0.18/ConvertRangeSyntax.elm b/tests/test-files/transform/Elm-0.18/ConvertRangeSyntax.elm new file mode 100644 index 000000000..424b6f25c --- /dev/null +++ b/tests/test-files/transform/Elm-0.18/ConvertRangeSyntax.elm @@ -0,0 +1,17 @@ +module ConvertRangeSyntax exposing (..) + +withoutComments = [1..9] + +withLeadingComments1 = + [--A + 1 + .. + --B + 9] + + +withLeadingComments2 = + [{-A-}1 .. {-B-}9] + +withComments = + [{-A-}1{-B-}..{-C-}9{-D-}] diff --git a/tests/test-files/transform/Elm-0.18/ConvertRangeSyntax.formatted.elm b/tests/test-files/transform/Elm-0.18/ConvertRangeSyntax.formatted.elm new file mode 100644 index 000000000..9411d105c --- /dev/null +++ b/tests/test-files/transform/Elm-0.18/ConvertRangeSyntax.formatted.elm @@ -0,0 +1,21 @@ +module ConvertRangeSyntax exposing (..) + + +withoutComments = + List.range 1 9 + + +withLeadingComments1 = + List.range + --A + 1 + --B + 9 + + +withLeadingComments2 = + List.range {- A -} 1 {- B -} 9 + + +withComments = + List.range ({- A -} 1 {- B -}) ({- C -} 9 {- D -}) diff --git a/tests/test-files/transform/Elm-0.18/UnnecessaryParens.elm b/tests/test-files/transform/Elm-0.18/UnnecessaryParens.elm index 3eade36ee..37990d1e6 100644 --- a/tests/test-files/transform/Elm-0.18/UnnecessaryParens.elm +++ b/tests/test-files/transform/Elm-0.18/UnnecessaryParens.elm @@ -31,6 +31,14 @@ unnecessaryParens = ) +nestedParensMergeComments = + ({- A -} ({- B -} 0 {- C -}) {- D -}) + + +nestedParensMergeComments2 f = + f {- A -} ({- B -} 0) + + allowedParens = ( (x + 1) + (y - 1) , () diff --git a/tests/test-files/transform/Elm-0.18/UnnecessaryParens.formatted.elm b/tests/test-files/transform/Elm-0.18/UnnecessaryParens.formatted.elm index eac049a9b..e1ce19650 100644 --- a/tests/test-files/transform/Elm-0.18/UnnecessaryParens.formatted.elm +++ b/tests/test-files/transform/Elm-0.18/UnnecessaryParens.formatted.elm @@ -31,6 +31,14 @@ unnecessaryParens = ) +nestedParensMergeComments = + ({- A -} {- B -} 0 {- C -} {- D -}) + + +nestedParensMergeComments2 f = + f {- A -} {- B -} 0 + + allowedParens = ( (x + 1) + (y - 1) , ()