Add instance Lift (Expr s a) (#1119)

This allows Exprs to be lifted in template-haskell. This is useful to
build a [dhall||] quasiquoter
This commit is contained in:
Ollie Charles 2019-07-21 20:10:54 +01:00 committed by Gabriel Gonzalez
parent c8a0df3748
commit d55bf8f3a3
10 changed files with 80 additions and 1 deletions

View File

@ -562,6 +562,7 @@ Library
scientific >= 0.3.0.0 && < 0.4 , scientific >= 0.3.0.0 && < 0.4 ,
template-haskell < 2.15, template-haskell < 2.15,
text >= 0.11.1.0 && < 1.3 , text >= 0.11.1.0 && < 1.3 ,
th-lift-instances >= 0.1.13 && < 0.2 ,
transformers >= 0.2.0.0 && < 0.6 , transformers >= 0.2.0.0 && < 0.6 ,
transformers-compat >= 0.6.2 && < 0.7 , transformers-compat >= 0.6.2 && < 0.7 ,
unordered-containers >= 0.1.3.0 && < 0.3 , unordered-containers >= 0.1.3.0 && < 0.3 ,

View File

@ -91,6 +91,8 @@ import Dhall.Set (Set)
import Dhall.Src (Src) import Dhall.Src (Src)
import {-# SOURCE #-} Dhall.Pretty.Internal import {-# SOURCE #-} Dhall.Pretty.Internal
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Instances.TH.Lift ()
import Language.Haskell.TH.Syntax (Lift)
import Numeric.Natural (Natural) import Numeric.Natural (Natural)
import Prelude hiding (succ) import Prelude hiding (succ)
@ -131,6 +133,8 @@ import qualified Text.Printf
data Const = Type | Kind | Sort data Const = Type | Kind | Sort
deriving (Show, Eq, Ord, Data, Bounded, Enum, Generic, NFData) deriving (Show, Eq, Ord, Data, Bounded, Enum, Generic, NFData)
instance Lift Const
instance Pretty Const where instance Pretty Const where
pretty = Pretty.unAnnotate . prettyConst pretty = Pretty.unAnnotate . prettyConst
@ -342,6 +346,8 @@ instance Pretty Import where
data Var = V Text !Int data Var = V Text !Int
deriving (Data, Generic, Eq, Ord, Show, NFData) deriving (Data, Generic, Eq, Ord, Show, NFData)
instance Lift Var
instance IsString Var where instance IsString Var where
fromString str = V (fromString str) 0 fromString str = V (fromString str) 0
@ -491,6 +497,8 @@ data Expr s a
-- NB: If you add a constructor to Expr, please also update the Arbitrary -- NB: If you add a constructor to Expr, please also update the Arbitrary
-- instance in Dhall.Test.QuickCheck. -- instance in Dhall.Test.QuickCheck.
instance (Lift s, Lift a, Data s, Data a) => Lift (Expr s a)
-- This instance is hand-written due to the fact that deriving -- This instance is hand-written due to the fact that deriving
-- it does not give us an INLINABLE pragma. We annotate this fmap -- it does not give us an INLINABLE pragma. We annotate this fmap
-- implementation with this pragma below to allow GHC to, possibly, -- implementation with this pragma below to allow GHC to, possibly,
@ -717,6 +725,8 @@ data Binding s a = Binding
, value :: Expr s a , value :: Expr s a
} deriving (Functor, Foldable, Generic, Traversable, Show, Eq, Ord, Data, NFData) } deriving (Functor, Foldable, Generic, Traversable, Show, Eq, Ord, Data, NFData)
instance (Lift s, Lift a, Data s, Data a) => Lift (Binding s a)
instance Bifunctor Binding where instance Bifunctor Binding where
first k (Binding a b c) = Binding a (fmap (first k) b) (first k c) first k (Binding a b c) = Binding a (fmap (first k) b) (first k c)
@ -726,6 +736,8 @@ instance Bifunctor Binding where
data Chunks s a = Chunks [(Text, Expr s a)] Text data Chunks s a = Chunks [(Text, Expr s a)] Text
deriving (Functor, Foldable, Generic, Traversable, Show, Eq, Ord, Data, NFData) deriving (Functor, Foldable, Generic, Traversable, Show, Eq, Ord, Data, NFData)
instance (Lift s, Lift a, Data s, Data a) => Lift (Chunks s a)
instance Data.Semigroup.Semigroup (Chunks s a) where instance Data.Semigroup.Semigroup (Chunks s a) where
Chunks xysL zL <> Chunks [] zR = Chunks xysL zL <> Chunks [] zR =
Chunks xysL (zL <> zR) Chunks xysL (zL <> zR)

View File

@ -69,6 +69,8 @@ import Control.DeepSeq (NFData)
import Data.Data (Data) import Data.Data (Data)
import Data.Semigroup import Data.Semigroup
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Instances.TH.Lift ()
import Language.Haskell.TH.Syntax (Lift)
import Prelude hiding (filter, lookup) import Prelude hiding (filter, lookup)
import qualified Data.List import qualified Data.List
@ -87,11 +89,15 @@ import qualified Prelude
data Map k v = Map (Data.Map.Map k v) (Keys k) data Map k v = Map (Data.Map.Map k v) (Keys k)
deriving (Data, Generic, NFData) deriving (Data, Generic, NFData)
instance (Data k, Data v, Lift k, Lift v, Ord k) => Lift (Map k v)
data Keys a data Keys a
= Sorted = Sorted
| Original [a] | Original [a]
deriving (Data, Generic, NFData) deriving (Data, Generic, NFData)
instance (Data a, Lift a) => Lift (Keys a)
instance (Ord k, Eq v) => Eq (Map k v) where instance (Ord k, Eq v) => Eq (Map k v) where
m1 == m2 = m1 == m2 =
Data.Map.size (toMap m1) == Data.Map.size (toMap m2) Data.Map.size (toMap m1) == Data.Map.size (toMap m2)

View File

@ -28,6 +28,8 @@ import Data.List (foldl')
import Data.Sequence (Seq, (|>)) import Data.Sequence (Seq, (|>))
import Data.Data (Data) import Data.Data (Data)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Instances.TH.Lift ()
import Language.Haskell.TH.Syntax (Lift)
import qualified Data.Set import qualified Data.Set
import qualified Data.Sequence import qualified Data.Sequence
@ -36,6 +38,8 @@ import qualified Data.Foldable
data Set a = Set (Data.Set.Set a) (Seq a) data Set a = Set (Data.Set.Set a) (Seq a)
deriving (Eq, Generic, Ord, Show, Data, NFData) deriving (Eq, Generic, Ord, Show, Data, NFData)
instance (Data a, Lift a, Ord a) => Lift (Set a)
instance Foldable Set where instance Foldable Set where
foldMap f = foldMap f . toSeq foldMap f = foldMap f . toSeq

View File

@ -2,6 +2,7 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
-- | This module provides the `Src` type used for source spans in error messages -- | This module provides the `Src` type used for source spans in error messages
@ -16,7 +17,9 @@ import Data.Monoid ((<>))
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Prettyprint.Doc (Pretty (..)) import Data.Text.Prettyprint.Doc (Pretty (..))
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Text.Megaparsec (SourcePos) import Instances.TH.Lift ()
import Language.Haskell.TH.Syntax (Lift, lift)
import Text.Megaparsec (SourcePos (SourcePos), mkPos, unPos)
import {-# SOURCE #-} qualified Dhall.Util import {-# SOURCE #-} qualified Dhall.Util
@ -29,6 +32,17 @@ data Src = Src !SourcePos !SourcePos Text
-- Text field is intentionally lazy -- Text field is intentionally lazy
deriving (Data, Eq, Generic, Ord, Show, NFData) deriving (Data, Eq, Generic, Ord, Show, NFData)
instance Lift Src where
lift (Src (SourcePos a b c) (SourcePos d e f) g) =
[| Src (SourcePos a (mkPos b') (mkPos c')) (SourcePos d (mkPos e') (mkPos f')) g |]
where
b' = unPos b
c' = unPos c
e' = unPos e
f' = unPos f
instance Pretty Src where instance Pretty Src where
pretty (Src begin _ text) = pretty (Src begin _ text) =
pretty (Dhall.Util.snip numberedLines) pretty (Dhall.Util.snip numberedLines)

View File

@ -4,6 +4,8 @@ module Dhall.X where
import Data.Data (Data(..)) import Data.Data (Data(..))
import Data.Text.Prettyprint.Doc (Pretty(..)) import Data.Text.Prettyprint.Doc (Pretty(..))
import Instances.TH.Lift ()
import Language.Haskell.TH.Syntax (Lift, lift)
-- | Like `Data.Void.Void`, except with a shorter inferred type -- | Like `Data.Void.Void`, except with a shorter inferred type
newtype X = X { absurd :: forall a . a } newtype X = X { absurd :: forall a . a }
@ -21,3 +23,6 @@ instance Data X where
instance Pretty X where instance Pretty X where
pretty = absurd pretty = absurd
instance Lift X where
lift (X impossible) = impossible

18
nix/th-lift-instances.nix Normal file
View File

@ -0,0 +1,18 @@
{ mkDerivation, base, bytestring, containers, QuickCheck, stdenv
, template-haskell, text, th-lift, transformers, vector
}:
mkDerivation {
pname = "th-lift-instances";
version = "0.1.13";
sha256 = "4ecf55e742f0e40ad915ee26dbea19cc7320452a9b217d490af1393a52f9b07e";
libraryHaskellDepends = [
base bytestring containers template-haskell text th-lift
transformers vector
];
testHaskellDepends = [
base bytestring containers QuickCheck template-haskell text vector
];
homepage = "http://github.com/bennofs/th-lift-instances/";
description = "Lift instances for template-haskell for common data types";
license = stdenv.lib.licenses.bsd3;
}

15
nix/th-lift.nix Normal file
View File

@ -0,0 +1,15 @@
{ mkDerivation, base, ghc-prim, stdenv, template-haskell
, th-abstraction
}:
mkDerivation {
pname = "th-lift";
version = "0.8.0.1";
sha256 = "a05133d8eac584fe47d8ff02163bb86193ce1f5de325ba73c98e95f0daa2d8a8";
libraryHaskellDepends = [
base ghc-prim template-haskell th-abstraction
];
testHaskellDepends = [ base ghc-prim template-haskell ];
homepage = "http://github.com/mboes/th-lift";
description = "Derive Template Haskell's Lift class for datatypes";
license = stdenv.lib.licenses.bsd3;
}

View File

@ -17,6 +17,8 @@ extra-deps:
- turtle-1.5.14 - turtle-1.5.14
- transformers-compat-0.6.4 - transformers-compat-0.6.4
- yaml-0.10.4.0 - yaml-0.10.4.0
- th-lift-instances-0.1.13@sha256:2852e468511805cb25d9e3923c9e91647d008ab4a764ec0921e5e40ff8a8e874,2625
- th-lift-0.8.0.1@sha256:cceb81b12c0580e02a7a3898b6d60cca5e1be080741f69ddde4f12210d8ba7ca,1960
flags: flags:
transformers-compat: transformers-compat:
five-three: true five-three: true

View File

@ -6,6 +6,8 @@ packages:
- dhall-lsp-server - dhall-lsp-server
extra-deps: extra-deps:
- repline-0.2.1.0 - repline-0.2.1.0
- th-lift-instances-0.1.13@sha256:2852e468511805cb25d9e3923c9e91647d008ab4a764ec0921e5e40ff8a8e874,2625
- th-lift-0.8.0.1@sha256:cceb81b12c0580e02a7a3898b6d60cca5e1be080741f69ddde4f12210d8ba7ca,1960
nix: nix:
packages: packages:
- ncurses - ncurses