Big internals refactoring

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:

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"
         ]

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 ""
 
 

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,14 +88,15 @@ 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
         CommandLine.World
         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

avh4-lib/src/CommandLine/World.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE TypeFamilies #-}
 module CommandLine.World where
 
 import Prelude ()

avh4-lib/src/CommandLine/World/IO.hs

@@ -1,5 +1,4 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
-{-# LANGUAGE TypeFamilies #-}
 module CommandLine.World.IO where
 
 import Prelude ()

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 <https://hackage.haskell.org/package/utility-ht-0.0.16/docs/Data-List-HT.html#v:segmentBeforeRight>
+-}
+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

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

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)

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)

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.
 -}