5f5f922 · ormolu · git.iko.soy

git.iko.soy/ormolu

Implement rendering of instance declarations

This pull request implements half of #49. Specifically, it deals with pretty printing instance declarations and most structures needed to support that. This includes pretty printing of associated types (and therefore also type family instances.) However, this _does not_ include pretty printing of associated data types. Pretty printing of type class declarations is to be dealt with at a later time. Instances are formatted such that indentation hangs after the `instance`. Namely, ```haskell instance Eq a => Eq [a] where ``` To support pretty printing associated types, the function `p_tyFamInstEqn` was exported from the appropriate module. This was done to avoid redundant code duplication.

commit5f5f9227aa05d073792d77207e39e4b5764b3ec7 authoryumiova <yumiova@protonmail.ch> dateThu 6 Jun 2019, 21:01 (7 years ago) parent59bc871

21 files changed+251

compare with master

unifiedsplit

data/examples/declaration/instance/associated-types-out.hsnew file+9

@@ -0,0 +1,9 @@

1+{-# LANGUAGE TypeFamilies #-}

2+instance Foo Int where

3+ type Bar Int = Double

5+instance Foo Double where

6+ type Bar Double =

7+ [Double]

8+ type Baz Double =

9+ [Double]

data/examples/declaration/instance/associated-types.hsnew file+13

@@ -0,0 +1,13 @@

1+{-# LANGUAGE TypeFamilies #-}

3+instance Foo Int where type Bar Int = Double

5+instance Foo Double

6+ where

7+ type

8+ Bar

9+ Double

10+ =

11+ [Double]

12+ type instance Baz Double

13+ = [Double]

data/examples/declaration/instance/contexts-out.hsnew file+9

@@ -0,0 +1,9 @@

1+instance Eq a => Eq [a] where

2+ (==) _ _ = False

4+instance ( Ord a

5+ , Ord b

6+ )

7+ => Ord

8+ (a, b) where

9+ compare _ _ = GT

data/examples/declaration/instance/contexts.hsnew file+7

@@ -0,0 +1,7 @@

1+instance Eq a=>Eq [a] where (==) _ _ = False

3+instance (

4+ Ord a,

5+ Ord b

6+ ) => Ord (a,b) where

7+ compare _ _ = GT

data/examples/declaration/instance/empty-instance-out.hsnew file+3

@@ -0,0 +1,3 @@

1+instance Typeable Int

3+instance Generic Int

data/examples/declaration/instance/empty-instance.hsnew file+2

@@ -0,0 +1,2 @@

1+instance Typeable Int

2+instance Generic Int where

data/examples/declaration/instance/instance-sigs-out.hsnew file+22

@@ -0,0 +1,22 @@

1+{-# LANGUAGE InstanceSigs #-}

2+instance Eq Int where

3+ (==) :: Int -> Int -> Bool

4+ (==) _ _ = False

6+instance Ord Int where

7+ compare

8+ :: Int

9+ -> Int

10+ -> Ordering

11+ compare

12+ _

13+ _ = GT

14+

15+instance Applicative [] where

16+ pure

17+ :: a

18+ -> [a]

19+ pure a = [a]

20+ (<*>)

21+ :: [a] -> [a] -> [a]

22+ (<*>) _ _ = []

data/examples/declaration/instance/instance-sigs.hsnew file+25

@@ -0,0 +1,25 @@

1+{-# LANGUAGE InstanceSigs #-}

3+instance Eq Int

4+ where

5+ (==) :: Int -> Int -> Bool

6+ (==) _ _ = False

8+instance Ord Int where

9+ compare ::

10+ Int

11+ -> Int

12+ -> Ordering

13+ compare

14+ _

15+ _

16+ = GT

17+

18+instance Applicative [] where

19+ pure ::

20+ a

21+ -> [a]

22+ pure a = [a]

23+ (<*>)

24+ :: [ a ] -> [ a ] -> [ a ]

25+ (<*>) _ _ = []

data/examples/declaration/instance/multi-parameter-out.hsnew file+6

@@ -0,0 +1,6 @@

1+instance MonadReader a ((->) a) where

2+ ask = id

4+instance MonadState s (State s) where

5+ get = State.get

6+ put = State.put

data/examples/declaration/instance/multi-parameter.hsnew file+6

@@ -0,0 +1,6 @@

1+instance MonadReader a ((->) a) where ask = id

3+instance MonadState s (State s)

4+ where

5+ get = State.get

6+ put = State.put

data/examples/declaration/instance/overlappable-instances-out.hsnew file+16

@@ -0,0 +1,16 @@

1+-- Test should have tested different whitespaces inside pragma. However, the

2+-- pragmas contain a "SourceText" which compares as equal only if the whitespace

3+-- inside the pragma is printed exactly identically (i.e. including newlines and

4+-- all.) In practice, removing this whitespace is desirable, so whitespace is

5+-- not varied to avoid spurious and difficult-to-avoid test case errors.

6+instance {-# OVERLAPPABLE #-} Eq Int where

7+ (==) _ _ = False

9+instance {-# OVERLAPPING #-} Ord Int where

10+ compare _ _ = GT

11+

12+instance {-# OVERLAPS #-} Eq Double where

13+ (==) _ _ = False

14+

15+instance {-# INCOHERENT #-} Ord Double where

16+ compare _ _ = GT

data/examples/declaration/instance/overlappable-instances.hsnew file+17

@@ -0,0 +1,17 @@

1+-- Test should have tested different whitespaces inside pragma. However, the

2+-- pragmas contain a "SourceText" which compares as equal only if the whitespace

3+-- inside the pragma is printed exactly identically (i.e. including newlines and

4+-- all.) In practice, removing this whitespace is desirable, so whitespace is

5+-- not varied to avoid spurious and difficult-to-avoid test case errors.

7+instance {-# OVERLAPPABLE #-} Eq Int where (==) _ _ = False

9+instance

10+ {-# OVERLAPPING #-} Ord Int where compare _ _ = GT

11+

12+instance {-# OVERLAPS #-} Eq Double where

13+ (==) _ _ = False

14+

15+instance

16+ {-# INCOHERENT #-} Ord Double where

17+ compare _ _ = GT

data/examples/declaration/instance/single-parameter-out.hsnew file+7

@@ -0,0 +1,7 @@

1+instance Monoid Int where

2+ (<>) x y = x + y

4+instance Enum Int where

5+ fromEnum x = x

6+ toEnum = \x ->

7+ x

data/examples/declaration/instance/single-parameter.hsnew file+8

@@ -0,0 +1,8 @@

1+instance Monoid Int where (<>) x y = x+y

3+instance Enum Int

4+ where

5+ fromEnum x = x

6+ toEnum

7+ = \x ->

8+ x

data/examples/declaration/instance/type-family-instances-out.hsnew file+7

@@ -0,0 +1,7 @@

1+{-# LANGUAGE TypeFamilies #-}

2+type instance Foo Int = Int

4+type instance Foo [Int] =

5+ ( Int

6+ , Int

7+ )

data/examples/declaration/instance/type-family-instances.hsnew file+9

@@ -0,0 +1,9 @@

1+{-# LANGUAGE TypeFamilies #-}

3+type instance Foo Int = Int

5+type instance

6+ Foo

7+ [Int] = ( Int,

8+ Int

9+ )

ormolu.cabal+1

@@ -60,6 +60,7 @@ library

6060 , Ormolu.Printer.Internal

6161 , Ormolu.Printer.Meat.Common

6262 , Ormolu.Printer.Meat.Declaration

63+ , Ormolu.Printer.Meat.Declaration.Instance

6364 , Ormolu.Printer.Meat.Declaration.Data

6465 , Ormolu.Printer.Meat.Declaration.Signature

6566 , Ormolu.Printer.Meat.Declaration.Type

src/Ormolu/Printer/Meat/Declaration.hs+8

@@ -11,6 +11,7 @@ where

1111import GHC

1212import Ormolu.Printer.Combinators

1313import Ormolu.Printer.Meat.Declaration.Data

14+import Ormolu.Printer.Meat.Declaration.Instance

1415import Ormolu.Printer.Meat.Declaration.Signature

1516import Ormolu.Printer.Meat.Declaration.Type

1617import Ormolu.Printer.Meat.Declaration.TypeFamily

@@ -22,6 +23,7 @@ p_hsDecl = \case

2223 TyClD NoExt x -> p_tyClDecl x

2324 ValD NoExt x -> p_valDecl x

2425 SigD NoExt x -> p_sigDecl x

26+ InstD NoExt x -> p_instDecl x

2527 _ -> notImplemented "certain kinds of declarations"

2628

2729p_tyClDecl :: TyClDecl GhcPs -> R ()

@@ -30,3 +32,9 @@ p_tyClDecl = \case

3032 SynDecl {..} -> p_synDecl tcdLName tcdTyVars tcdRhs

3133 DataDecl {..} -> p_dataDecl tcdLName tcdTyVars tcdDataDefn

3234 _ -> notImplemented "certain kinds of declarations"

35+

36+p_instDecl :: InstDecl GhcPs -> R ()

37+p_instDecl = \case

38+ ClsInstD NoExt x -> p_clsInstDecl x

39+ TyFamInstD NoExt x -> p_tyFamInstDecl Free x

40+ _ -> notImplemented "certain kinds of declarations"

src/Ormolu/Printer/Meat/Declaration/Instance.hsnew file+71

@@ -0,0 +1,71 @@

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE RecordWildCards #-}

5+-- | Type class instance declarations.

7+module Ormolu.Printer.Meat.Declaration.Instance

8+ ( p_clsInstDecl

9+ , FamilyStyle (Associate, Free)

10+ , p_tyFamInstDecl

11+ )

12+where

13+

14+import BasicTypes

15+import Control.Arrow

16+import Data.Foldable

17+import Data.Function

18+import Data.List (sortBy)

19+import GHC

20+import Ormolu.Printer.Combinators

21+import Ormolu.Printer.Meat.Declaration.Signature

22+import Ormolu.Printer.Meat.Declaration.TypeFamily

23+import Ormolu.Printer.Meat.Declaration.Value

24+import Ormolu.Printer.Meat.Type

25+import Ormolu.Utils

26+

27+p_clsInstDecl :: ClsInstDecl GhcPs -> R ()

28+p_clsInstDecl = \case

29+ ClsInstDecl {..} -> do

30+ txt "instance "

31+ case unLoc <$> cid_overlap_mode of

32+ Just Overlappable {} -> txt "{-# OVERLAPPABLE #-} "

33+ Just Overlapping {} -> txt "{-# OVERLAPPING #-} "

34+ Just Overlaps {} -> txt "{-# OVERLAPS #-} "

35+ Just Incoherent {} -> txt "{-# INCOHERENT #-} "

36+ _ -> pure ()

37+ case cid_poly_ty of

38+ HsIB {..} -> sitcc (located hsib_body p_hsType)

39+ XHsImplicitBndrs NoExt -> notImplemented "XHsImplicitBndrs"

40+ -- GHC's AST does not necessarily store each kind of element in source

41+ -- location order. This happens because different declarations are stored in

42+ -- different lists. Consequently, to get all the declarations in proper

43+ -- order, they need to be manually sorted.

44+ let binds = (getLoc &&& located' p_valDecl) <$> cid_binds

45+ sigs = (getLoc &&& located' p_sigDecl) <$> cid_sigs

46+ tyfam_insts =

47+ (getLoc &&& located' (p_tyFamInstDecl Associate)) <$> cid_tyfam_insts

48+ decls =

49+ snd <$>

50+ sortBy (compare `on` fst) (toList binds <> sigs <> tyfam_insts)

51+ if not (null decls)

52+ then do

53+ txt " where"

54+ newline

55+ inci (sequence_ decls)

56+ else do

57+ newline

58+ XClsInstDecl NoExt -> notImplemented "XClsInstDecl"

59+

60+data FamilyStyle

61+ = Associate

62+ | Free

63+

64+p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()

65+p_tyFamInstDecl style = \case

66+ TyFamInstDecl {..} -> do

67+ txt $ case style of

68+ Associate -> "type "

69+ Free -> "type instance "

70+ p_tyFamInstEqn tfid_eqn

71+ newline

src/Ormolu/Printer/Meat/Declaration/Signature.hs+4

@@ -10,6 +10,7 @@ module Ormolu.Printer.Meat.Declaration.Signature

1010 )

1111where

1212

13+import Control.Monad

1314import GHC

1415import Ormolu.Printer.Combinators

1516import Ormolu.Printer.Meat.Common

@@ -22,6 +23,9 @@ p_sigDecl = line . p_sigDecl'

2223p_sigDecl' :: Sig GhcPs -> R ()

2324p_sigDecl' = \case

2425 TypeSig NoExt names hswc -> p_typeSig names hswc

26+ ClassOpSig NoExt def names hsib -> do

27+ when def (txt "default ")

28+ p_typeSig names HsWC {hswc_ext = NoExt, hswc_body = hsib}

2529 _ -> notImplemented "certain types of signature declarations"

2630

2731p_typeSig

src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+1

@@ -6,6 +6,7 @@

77module Ormolu.Printer.Meat.Declaration.TypeFamily

88 ( p_famDecl

9+ , p_tyFamInstEqn

910 )

1011where

1112