From 22442312fe14838106723f2cb42c66c4c4dac8c7 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 26 Aug 2022 23:09:19 +0200 Subject: [PATCH 01/13] Split Dhall.Syntax - Moved functions and optics to Dhall.Syntax.Operations - Moved types to Dhall.Syntax.Types - Moved instances for the following classes to own modules in Dhall.Syntax.Instances: - Applicative - Bifunctor - Data - Eq - Foldable - Functor - Lift - Monad - Monoid - NFData - Ord - Pretty - Semigroup - Show - Traversable Only the following instances are in Dhall.Syntax.Types: Generic, IsString, Bounded, Enum - Monad Expr is using Monad Applicative and not the other way round --- dhall/dhall.cabal | 17 + dhall/src/Dhall/Pretty/Internal.hs | 1 + dhall/src/Dhall/Pretty/Internal.hs-boot | 2 +- dhall/src/Dhall/Syntax.hs | 1506 +---------------- .../src/Dhall/Syntax/Instances/Applicative.hs | 32 + dhall/src/Dhall/Syntax/Instances/Bifunctor.hs | 47 + dhall/src/Dhall/Syntax/Instances/Data.hs | 21 + dhall/src/Dhall/Syntax/Instances/Eq.hs | 55 + dhall/src/Dhall/Syntax/Instances/Foldable.hs | 16 + dhall/src/Dhall/Syntax/Instances/Functor.hs | 33 + dhall/src/Dhall/Syntax/Instances/Lift.hs | 28 + dhall/src/Dhall/Syntax/Instances/Monad.hs | 13 + dhall/src/Dhall/Syntax/Instances/Monoid.hs | 9 + dhall/src/Dhall/Syntax/Instances/NFData.hs | 27 + dhall/src/Dhall/Syntax/Instances/Ord.hs | 37 + dhall/src/Dhall/Syntax/Instances/Pretty.hs | 131 ++ .../src/Dhall/Syntax/Instances/Pretty.hs-boot | 8 + dhall/src/Dhall/Syntax/Instances/Semigroup.hs | 56 + dhall/src/Dhall/Syntax/Instances/Show.hs | 28 + .../src/Dhall/Syntax/Instances/Traversable.hs | 18 + dhall/src/Dhall/Syntax/Operations.hs | 543 ++++++ dhall/src/Dhall/Syntax/Operations.hs-boot | 5 + dhall/src/Dhall/Syntax/Types.hs | 638 +++++++ dhall/src/Dhall/Syntax/Types.hs-boot | 7 + 24 files changed, 1790 insertions(+), 1488 deletions(-) create mode 100644 dhall/src/Dhall/Syntax/Instances/Applicative.hs create mode 100644 dhall/src/Dhall/Syntax/Instances/Bifunctor.hs create mode 100644 dhall/src/Dhall/Syntax/Instances/Data.hs create mode 100644 dhall/src/Dhall/Syntax/Instances/Eq.hs create mode 100644 dhall/src/Dhall/Syntax/Instances/Foldable.hs create mode 100644 dhall/src/Dhall/Syntax/Instances/Functor.hs create mode 100644 dhall/src/Dhall/Syntax/Instances/Lift.hs create mode 100644 dhall/src/Dhall/Syntax/Instances/Monad.hs create mode 100644 dhall/src/Dhall/Syntax/Instances/Monoid.hs create mode 100644 dhall/src/Dhall/Syntax/Instances/NFData.hs create mode 100644 dhall/src/Dhall/Syntax/Instances/Ord.hs create mode 100644 dhall/src/Dhall/Syntax/Instances/Pretty.hs create mode 100644 dhall/src/Dhall/Syntax/Instances/Pretty.hs-boot create mode 100644 dhall/src/Dhall/Syntax/Instances/Semigroup.hs create mode 100644 dhall/src/Dhall/Syntax/Instances/Show.hs create mode 100644 dhall/src/Dhall/Syntax/Instances/Traversable.hs create mode 100644 dhall/src/Dhall/Syntax/Operations.hs create mode 100644 dhall/src/Dhall/Syntax/Operations.hs-boot create mode 100644 dhall/src/Dhall/Syntax/Types.hs create mode 100644 dhall/src/Dhall/Syntax/Types.hs-boot diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index fdee111fd..df03c332e 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -360,6 +360,23 @@ Library Dhall.Parser.Combinators Dhall.Pretty.Internal Dhall.Syntax + Dhall.Syntax.Instances.Applicative + Dhall.Syntax.Instances.Bifunctor + Dhall.Syntax.Instances.Data + Dhall.Syntax.Instances.Eq + Dhall.Syntax.Instances.Foldable + Dhall.Syntax.Instances.Functor + Dhall.Syntax.Instances.Lift + Dhall.Syntax.Instances.Monad + Dhall.Syntax.Instances.Monoid + Dhall.Syntax.Instances.NFData + Dhall.Syntax.Instances.Ord + Dhall.Syntax.Instances.Pretty + Dhall.Syntax.Instances.Semigroup + Dhall.Syntax.Instances.Show + Dhall.Syntax.Instances.Traversable + Dhall.Syntax.Operations + Dhall.Syntax.Types Dhall.URL Paths_dhall Autogen-Modules: diff --git a/dhall/src/Dhall/Pretty/Internal.hs b/dhall/src/Dhall/Pretty/Internal.hs index 3b45ffb8a..df750b991 100644 --- a/dhall/src/Dhall/Pretty/Internal.hs +++ b/dhall/src/Dhall/Pretty/Internal.hs @@ -83,6 +83,7 @@ import Dhall.Map (Map) import Dhall.Optics (cosmosOf, foldOf, to) import Dhall.Src (Src (..)) import Dhall.Syntax +import {-# SOURCE #-} Dhall.Syntax.Instances.Pretty () import GHC.Generics (Generic) import Language.Haskell.TH.Syntax (Lift) import Numeric.Natural (Natural) diff --git a/dhall/src/Dhall/Pretty/Internal.hs-boot b/dhall/src/Dhall/Pretty/Internal.hs-boot index 91b60f9e2..0ccec6cd3 100644 --- a/dhall/src/Dhall/Pretty/Internal.hs-boot +++ b/dhall/src/Dhall/Pretty/Internal.hs-boot @@ -7,7 +7,7 @@ import Prettyprinter (Pretty, Doc) import Dhall.Src (Src) import Language.Haskell.TH.Syntax (Lift) -import {-# SOURCE #-} Dhall.Syntax +import {-# SOURCE #-} Dhall.Syntax.Types data Ann diff --git a/dhall/src/Dhall/Syntax.hs b/dhall/src/Dhall/Syntax.hs index 83ca37907..deb67fa50 100644 --- a/dhall/src/Dhall/Syntax.hs +++ b/dhall/src/Dhall/Syntax.hs @@ -1,1489 +1,21 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UnicodeSyntax #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -{-| This module contains the core syntax types and optics for them. - -'reservedIdentifiers', 'denote' and friends are included because they are -involved in a dependency circle with "Dhall.Pretty.Internal". --} - -module Dhall.Syntax ( - -- * 'Expr' - Const(..) - , Var(..) - , Binding(..) - , makeBinding - , CharacterSet(..) - , Chunks(..) - , DhallDouble(..) - , PreferAnnotation(..) - , Expr(..) - , RecordField(..) - , makeRecordField - , FunctionBinding(..) - , makeFunctionBinding - , FieldSelection(..) - , makeFieldSelection - , WithComponent(..) - - -- ** 'Let'-blocks - , MultiLet(..) - , multiLet - , wrapInLets - - -- ** Optics - , subExpressions - , subExpressionsWith - , unsafeSubExpressions - , chunkExprs - , bindingExprs - , recordFieldExprs - , functionBindingExprs - - -- ** Handling 'Note's - , denote - , renote - , shallowDenote - - -- * 'Import' - , Directory(..) - , File(..) - , FilePrefix(..) - , Import(..) - , ImportHashed(..) - , ImportMode(..) - , ImportType(..) - , URL(..) - , Scheme(..) - , pathCharacter - - -- * Reserved identifiers - , reservedIdentifiers - , reservedKeywords - - -- * `Data.Text.Text` manipulation - , toDoubleQuoted - , longestSharedWhitespacePrefix - , linesLiteral - , unlinesLiteral - - -- * Utilities - , internalError - -- `shift` should really be in `Dhall.Normalize`, but it's here to avoid a - -- module cycle - , shift +module Dhall.Syntax + ( module Export ) where -import Control.DeepSeq (NFData) -import Data.Bifunctor (Bifunctor (..)) -import Data.Bits (xor) -import Data.Data (Data) -import Data.Foldable -import Data.HashSet (HashSet) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Sequence (Seq) -import Data.String (IsString (..)) -import Data.Text (Text) -import Data.Traversable () -import Data.Void (Void) -import Dhall.Map (Map) -import {-# SOURCE #-} Dhall.Pretty.Internal -import Dhall.Src (Src (..)) -import GHC.Generics (Generic) -import Instances.TH.Lift () -import Language.Haskell.TH.Syntax (Lift) -import Numeric.Natural (Natural) -import Prettyprinter (Doc, Pretty) -import Unsafe.Coerce (unsafeCoerce) - -import qualified Control.Monad -import qualified Data.Fixed as Fixed -import qualified Data.HashSet -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Text -import qualified Data.Time as Time -import qualified Dhall.Crypto -import qualified Lens.Family as Lens -import qualified Network.URI as URI -import qualified Prettyprinter as Pretty - -deriving instance Lift Time.Day -deriving instance Lift Time.TimeOfDay -deriving instance Lift Time.TimeZone -deriving instance Lift (Fixed.Fixed a) - --- $setup --- >>> import Dhall.Binary () -- For the orphan instance for `Serialise (Expr Void Import)` - -{-| Constants for a pure type system - - The axioms are: - -> ⊦ Type : Kind -> ⊦ Kind : Sort - - ... and the valid rule pairs are: - -> ⊦ Type ↝ Type : Type -- Functions from terms to terms (ordinary functions) -> ⊦ Kind ↝ Type : Type -- Functions from types to terms (type-polymorphic functions) -> ⊦ Sort ↝ Type : Type -- Functions from kinds to terms -> ⊦ Kind ↝ Kind : Kind -- Functions from types to types (type-level functions) -> ⊦ Sort ↝ Kind : Sort -- Functions from kinds to types (kind-polymorphic functions) -> ⊦ Sort ↝ Sort : Sort -- Functions from kinds to kinds (kind-level functions) - - Note that Dhall does not support functions from terms to types and therefore - Dhall is not a dependently typed language --} -data Const = Type | Kind | Sort - deriving (Show, Eq, Ord, Data, Bounded, Enum, Generic, Lift, NFData) - -instance Pretty Const where - pretty = Pretty.unAnnotate . prettyConst - -{-| Label for a bound variable - - The `Data.Text.Text` field is the variable's name (i.e. \"@x@\"). - - The `Int` field disambiguates variables with the same name if there are - multiple bound variables of the same name in scope. Zero refers to the - nearest bound variable and the index increases by one for each bound - variable of the same name going outward. The following diagram may help: - -> ┌──refers to──┐ -> │ │ -> v │ -> λ(x : Type) → λ(y : Type) → λ(x : Type) → x@0 -> -> ┌─────────────────refers to─────────────────┐ -> │ │ -> v │ -> λ(x : Type) → λ(y : Type) → λ(x : Type) → x@1 - - This `Int` behaves like a De Bruijn index in the special case where all - variables have the same name. - - You can optionally omit the index if it is @0@: - -> ┌─refers to─┐ -> │ │ -> v │ -> λ(x : Type) → λ(y : Type) → λ(x : Type) → x - - Zero indices are omitted when pretty-printing @Var@s and non-zero indices - appear as a numeric suffix. --} -data Var = V Text !Int - deriving (Data, Generic, Eq, Ord, Show, Lift, NFData) - -instance IsString Var where - fromString str = V (fromString str) 0 - -instance Pretty Var where - pretty = Pretty.unAnnotate . prettyVar - --- | Record the binding part of a @let@ expression. --- --- For example, --- --- > let {- A -} x {- B -} : {- C -} Bool = {- D -} True in x --- --- … will be instantiated as follows: --- --- * @bindingSrc0@ corresponds to the @A@ comment. --- * @variable@ is @"x"@ --- * @bindingSrc1@ corresponds to the @B@ comment. --- * @annotation@ is 'Just' a pair, corresponding to the @C@ comment and @Bool@. --- * @bindingSrc2@ corresponds to the @D@ comment. --- * @value@ corresponds to @True@. -data Binding s a = Binding - { bindingSrc0 :: Maybe s - , variable :: Text - , bindingSrc1 :: Maybe s - , annotation :: Maybe (Maybe s, Expr s a) - , bindingSrc2 :: Maybe s - , value :: Expr s a - } deriving (Data, Eq, Foldable, Functor, Generic, Lift, NFData, Ord, Show, Traversable) - -instance Bifunctor Binding where - first k (Binding src0 a src1 b src2 c) = - Binding (fmap k src0) a (fmap k src1) (fmap adapt0 b) (fmap k src2) (first k c) - where - adapt0 (src3, d) = (fmap k src3, first k d) - - second = fmap - -{-| Construct a 'Binding' with no source information and no type annotation. --} -makeBinding :: Text -> Expr s a -> Binding s a -makeBinding name = Binding Nothing name Nothing Nothing Nothing - --- | This wrapper around 'Prelude.Double' exists for its 'Eq' instance which is --- defined via the binary encoding of Dhall @Double@s. -newtype DhallDouble = DhallDouble { getDhallDouble :: Double } - deriving stock (Show, Data, Lift, Generic) - deriving anyclass NFData - --- | This instance satisfies all the customary 'Eq' laws except substitutivity. --- --- In particular: --- --- >>> nan = DhallDouble (0/0) --- >>> nan == nan --- True --- --- This instance is also consistent with with the binary encoding of Dhall @Double@s: --- --- >>> toBytes n = Dhall.Binary.encodeExpression (DoubleLit n :: Expr Void Import) --- --- prop> \a b -> (a == b) == (toBytes a == toBytes b) -instance Eq DhallDouble where - DhallDouble a == DhallDouble b - | isNaN a && isNaN b = True - | isNegativeZero a `xor` isNegativeZero b = False - | otherwise = a == b - --- | This instance relies on the 'Eq' instance for 'DhallDouble' but cannot --- satisfy the customary 'Ord' laws when @NaN@ is involved. -instance Ord DhallDouble where - compare a@(DhallDouble a') b@(DhallDouble b') = - if a == b - then EQ - else compare a' b' - --- | The body of an interpolated @Text@ literal -data Chunks s a = Chunks [(Text, Expr s a)] Text - deriving (Functor, Foldable, Generic, Traversable, Show, Eq, Ord, Data, Lift, NFData) - -instance Semigroup (Chunks s a) where - Chunks xysL zL <> Chunks [] zR = - Chunks xysL (zL <> zR) - Chunks xysL zL <> Chunks ((x, y):xysR) zR = - Chunks (xysL ++ (zL <> x, y):xysR) zR - -instance Monoid (Chunks s a) where - mempty = Chunks [] mempty - -instance IsString (Chunks s a) where - fromString str = Chunks [] (fromString str) - --- | Used to record the origin of a @//@ operator (i.e. from source code or a --- product of desugaring) -data PreferAnnotation s a - = PreferFromSource - | PreferFromWith (Expr s a) - -- ^ Stores the original @with@ expression - | PreferFromCompletion - deriving (Data, Eq, Foldable, Functor, Generic, Lift, NFData, Ord, Show, Traversable) - -instance Bifunctor PreferAnnotation where - first _ PreferFromSource = PreferFromSource - first f (PreferFromWith e ) = PreferFromWith (first f e) - first _ PreferFromCompletion = PreferFromCompletion - - second = fmap - --- | Record the field of a record-type and record-literal expression. --- The reason why we use the same ADT for both of them is because they store --- the same information. --- --- For example, --- --- > { {- A -} x {- B -} : {- C -} T } --- --- ... or --- --- > { {- A -} x {- B -} = {- C -} T } --- --- will be instantiated as follows: --- --- * @recordFieldSrc0@ corresponds to the @A@ comment. --- * @recordFieldValue@ is @"T"@ --- * @recordFieldSrc1@ corresponds to the @B@ comment. --- * @recordFieldSrc2@ corresponds to the @C@ comment. --- --- Although the @A@ comment isn't annotating the @"T"@ Record Field, --- this is the best place to keep these comments. --- --- Note that @recordFieldSrc2@ is always 'Nothing' when the 'RecordField' is for --- a punned entry, because there is no @=@ sign. For example, --- --- > { {- A -} x {- B -} } --- --- will be instantiated as follows: --- --- * @recordFieldSrc0@ corresponds to the @A@ comment. --- * @recordFieldValue@ corresponds to @(Var "x")@ --- * @recordFieldSrc1@ corresponds to the @B@ comment. --- * @recordFieldSrc2@ will be 'Nothing' --- --- The labels involved in a record using dot-syntax like in this example: --- --- > { {- A -} a {- B -} . {- C -} b {- D -} . {- E -} c {- F -} = {- G -} e } --- --- will be instantiated as follows: --- --- * For both the @a@ and @b@ field, @recordfieldSrc2@ is 'Nothing' --- * For the @a@ field: --- * @recordFieldSrc0@ corresponds to the @A@ comment --- * @recordFieldSrc1@ corresponds to the @B@ comment --- * For the @b@ field: --- * @recordFieldSrc0@ corresponds to the @C@ comment --- * @recordFieldSrc1@ corresponds to the @D@ comment --- * For the @c@ field: --- * @recordFieldSrc0@ corresponds to the @E@ comment --- * @recordFieldSrc1@ corresponds to the @F@ comment --- * @recordFieldSrc2@ corresponds to the @G@ comment --- --- That is, for every label except the last one the semantics of --- @recordFieldSrc0@ and @recordFieldSrc1@ are the same from a regular record --- label but @recordFieldSrc2@ is always 'Nothing'. For the last keyword, all --- srcs are 'Just' -data RecordField s a = RecordField - { recordFieldSrc0 :: Maybe s - , recordFieldValue :: Expr s a - , recordFieldSrc1 :: Maybe s - , recordFieldSrc2 :: Maybe s - } deriving (Data, Eq, Foldable, Functor, Generic, Lift, NFData, Ord, Show, Traversable) - --- | Construct a 'RecordField' with no src information -makeRecordField :: Expr s a -> RecordField s a -makeRecordField e = RecordField Nothing e Nothing Nothing - - -instance Bifunctor RecordField where - first k (RecordField s0 value s1 s2) = - RecordField (k <$> s0) (first k value) (k <$> s1) (k <$> s2) - second = fmap - --- | Record the label of a function or a function-type expression --- --- For example, --- --- > λ({- A -} a {- B -} : {- C -} T) -> e --- --- … will be instantiated as follows: --- --- * @functionBindingSrc0@ corresponds to the @A@ comment --- * @functionBindingVariable@ is @a@ --- * @functionBindingSrc1@ corresponds to the @B@ comment --- * @functionBindingSrc2@ corresponds to the @C@ comment --- * @functionBindingAnnotation@ is @T@ -data FunctionBinding s a = FunctionBinding - { functionBindingSrc0 :: Maybe s - , functionBindingVariable :: Text - , functionBindingSrc1 :: Maybe s - , functionBindingSrc2 :: Maybe s - , functionBindingAnnotation :: Expr s a - } deriving (Data, Eq, Foldable, Functor, Generic, Lift, NFData, Ord, Show, Traversable) - --- | Smart constructor for 'FunctionBinding' with no src information -makeFunctionBinding :: Text -> Expr s a -> FunctionBinding s a -makeFunctionBinding l t = FunctionBinding Nothing l Nothing Nothing t - -instance Bifunctor FunctionBinding where - first k (FunctionBinding src0 label src1 src2 type_) = - FunctionBinding (k <$> src0) label (k <$> src1) (k <$> src2) (first k type_) - - second = fmap - --- | Record the field on a selector-expression --- --- For example, --- --- > e . {- A -} x {- B -} --- --- … will be instantiated as follows: --- --- * @fieldSelectionSrc0@ corresponds to the @A@ comment --- * @fieldSelectionLabel@ corresponds to @x@ --- * @fieldSelectionSrc1@ corresponds to the @B@ comment --- --- Given our limitation that not all expressions recover their whitespaces, the --- purpose of @fieldSelectionSrc1@ is to save the 'Text.Megaparsec.SourcePos' --- where the @fieldSelectionLabel@ ends, but we /still/ use a 'Maybe Src' --- (@s = 'Src'@) to be consistent with similar data types such as 'Binding', for --- example. -data FieldSelection s = FieldSelection - { fieldSelectionSrc0 :: Maybe s - , fieldSelectionLabel :: !Text - , fieldSelectionSrc1 :: Maybe s - } deriving (Data, Eq, Foldable, Functor, Generic, Lift, NFData, Ord, Show, Traversable) - --- | Smart constructor for 'FieldSelection' with no src information -makeFieldSelection :: Text -> FieldSelection s -makeFieldSelection t = FieldSelection Nothing t Nothing - --- | A path component for a @with@ expression -data WithComponent = WithLabel Text | WithQuestion - deriving (Data, Eq, Generic, Lift, NFData, Ord, Show) - -{-| Syntax tree for expressions - - The @s@ type parameter is used to track the presence or absence of `Src` - spans: - - * If @s = `Src`@ then the code may contains `Src` spans (either in a `Note` - constructor or inline within another constructor, like `Let`) - * If @s = `Void`@ then the code has no `Src` spans - - The @a@ type parameter is used to track the presence or absence of imports - - * If @a = `Import`@ then the code may contain unresolved `Import`s - * If @a = `Void`@ then the code has no `Import`s --} -data Expr s a - -- | > Const c ~ c - = Const Const - -- | > Var (V x 0) ~ x - -- > Var (V x n) ~ x@n - | Var Var - -- | > Lam _ (FunctionBinding _ "x" _ _ A) b ~ λ(x : A) -> b - | Lam (Maybe CharacterSet) (FunctionBinding s a) (Expr s a) - -- | > Pi _ "_" A B ~ A -> B - -- > Pi _ x A B ~ ∀(x : A) -> B - | Pi (Maybe CharacterSet) Text (Expr s a) (Expr s a) - -- | > App f a ~ f a - | App (Expr s a) (Expr s a) - -- | > Let (Binding _ x _ Nothing _ r) e ~ let x = r in e - -- > Let (Binding _ x _ (Just t ) _ r) e ~ let x : t = r in e - -- - -- The difference between - -- - -- > let x = a let y = b in e - -- - -- and - -- - -- > let x = a in let y = b in e - -- - -- is only an additional 'Note' around @'Let' "y" …@ in the second - -- example. - -- - -- See 'MultiLet' for a representation of let-blocks that mirrors the - -- source code more closely. - | Let (Binding s a) (Expr s a) - -- | > Annot x t ~ x : t - | Annot (Expr s a) (Expr s a) - -- | > Bool ~ Bool - | Bool - -- | > BoolLit b ~ b - | BoolLit Bool - -- | > BoolAnd x y ~ x && y - | BoolAnd (Expr s a) (Expr s a) - -- | > BoolOr x y ~ x || y - | BoolOr (Expr s a) (Expr s a) - -- | > BoolEQ x y ~ x == y - | BoolEQ (Expr s a) (Expr s a) - -- | > BoolNE x y ~ x != y - | BoolNE (Expr s a) (Expr s a) - -- | > BoolIf x y z ~ if x then y else z - | BoolIf (Expr s a) (Expr s a) (Expr s a) - -- | > Natural ~ Natural - | Natural - -- | > NaturalLit n ~ n - | NaturalLit Natural - -- | > NaturalFold ~ Natural/fold - | NaturalFold - -- | > NaturalBuild ~ Natural/build - | NaturalBuild - -- | > NaturalIsZero ~ Natural/isZero - | NaturalIsZero - -- | > NaturalEven ~ Natural/even - | NaturalEven - -- | > NaturalOdd ~ Natural/odd - | NaturalOdd - -- | > NaturalToInteger ~ Natural/toInteger - | NaturalToInteger - -- | > NaturalShow ~ Natural/show - | NaturalShow - -- | > NaturalSubtract ~ Natural/subtract - | NaturalSubtract - -- | > NaturalPlus x y ~ x + y - | NaturalPlus (Expr s a) (Expr s a) - -- | > NaturalTimes x y ~ x * y - | NaturalTimes (Expr s a) (Expr s a) - -- | > Integer ~ Integer - | Integer - -- | > IntegerLit n ~ ±n - | IntegerLit Integer - -- | > IntegerClamp ~ Integer/clamp - | IntegerClamp - -- | > IntegerNegate ~ Integer/negate - | IntegerNegate - -- | > IntegerShow ~ Integer/show - | IntegerShow - -- | > IntegerToDouble ~ Integer/toDouble - | IntegerToDouble - -- | > Double ~ Double - | Double - -- | > DoubleLit n ~ n - | DoubleLit DhallDouble - -- | > DoubleShow ~ Double/show - | DoubleShow - -- | > Text ~ Text - | Text - -- | > TextLit (Chunks [(t1, e1), (t2, e2)] t3) ~ "t1${e1}t2${e2}t3" - | TextLit (Chunks s a) - -- | > TextAppend x y ~ x ++ y - | TextAppend (Expr s a) (Expr s a) - -- | > TextReplace ~ Text/replace - | TextReplace - -- | > TextShow ~ Text/show - | TextShow - -- | > Date ~ Date - | Date - -- | > DateLiteral (fromGregorian _YYYY _MM _DD) ~ YYYY-MM-DD - | DateLiteral Time.Day - -- | > Time ~ Time - | Time - -- | > TimeLiteral (TimeOfDay hh mm ss) _ ~ hh:mm:ss - | TimeLiteral - Time.TimeOfDay - Word - -- ^ Precision - -- | > TimeZone ~ TimeZone - | TimeZone - -- | > TimeZoneLiteral (TimeZone ( 60 * _HH + _MM) _ _) ~ +HH:MM - -- | > TimeZoneLiteral (TimeZone (-60 * _HH + _MM) _ _) ~ -HH:MM - | TimeZoneLiteral Time.TimeZone - -- | > List ~ List - | List - -- | > ListLit (Just t ) [] ~ [] : t - -- > ListLit Nothing [x, y, z] ~ [x, y, z] - -- - -- Invariant: A non-empty list literal is always represented as - -- @ListLit Nothing xs@. - -- - -- When an annotated, non-empty list literal is parsed, it is represented - -- as - -- - -- > Annot (ListLit Nothing [x, y, z]) t ~ [x, y, z] : t - - -- Eventually we should have separate constructors for empty and non-empty - -- list literals. For now it's easier to check the invariant in @infer@. - -- See https://github.com/dhall-lang/dhall-haskell/issues/1359#issuecomment-537087234. - | ListLit (Maybe (Expr s a)) (Seq (Expr s a)) - -- | > ListAppend x y ~ x # y - | ListAppend (Expr s a) (Expr s a) - -- | > ListBuild ~ List/build - | ListBuild - -- | > ListFold ~ List/fold - | ListFold - -- | > ListLength ~ List/length - | ListLength - -- | > ListHead ~ List/head - | ListHead - -- | > ListLast ~ List/last - | ListLast - -- | > ListIndexed ~ List/indexed - | ListIndexed - -- | > ListReverse ~ List/reverse - | ListReverse - -- | > Optional ~ Optional - | Optional - -- | > Some e ~ Some e - | Some (Expr s a) - -- | > None ~ None - | None - -- | > Record [ (k1, RecordField _ t1) ~ { k1 : t1, k2 : t1 } - -- > , (k2, RecordField _ t2) - -- > ] - | Record (Map Text (RecordField s a)) - -- | > RecordLit [ (k1, RecordField _ v1) ~ { k1 = v1, k2 = v2 } - -- > , (k2, RecordField _ v2) - -- > ] - | RecordLit (Map Text (RecordField s a)) - -- | > Union [(k1, Just t1), (k2, Nothing)] ~ < k1 : t1 | k2 > - | Union (Map Text (Maybe (Expr s a))) - -- | > Combine _ Nothing x y ~ x ∧ y - -- - -- The first field is a `Just` when the `Combine` operator is introduced - -- as a result of desugaring duplicate record fields: - -- - -- > RecordLit [ ( k ~ { k = x, k = y } - -- > , RecordField - -- > _ - -- > (Combine (Just k) x y) - -- > )] - | Combine (Maybe CharacterSet) (Maybe Text) (Expr s a) (Expr s a) - -- | > CombineTypes _ x y ~ x ⩓ y - | CombineTypes (Maybe CharacterSet) (Expr s a) (Expr s a) - -- | > Prefer _ False x y ~ x ⫽ y - -- - -- The first field is a `True` when the `Prefer` operator is introduced as a - -- result of desugaring a @with@ expression - | Prefer (Maybe CharacterSet) (PreferAnnotation s a) (Expr s a) (Expr s a) - -- | > RecordCompletion x y ~ x::y - | RecordCompletion (Expr s a) (Expr s a) - -- | > Merge x y (Just t ) ~ merge x y : t - -- > Merge x y Nothing ~ merge x y - | Merge (Expr s a) (Expr s a) (Maybe (Expr s a)) - -- | > ToMap x (Just t) ~ toMap x : t - -- > ToMap x Nothing ~ toMap x - | ToMap (Expr s a) (Maybe (Expr s a)) - -- | > ShowConstructor x ~ showConstructor x - | ShowConstructor (Expr s a) - -- | > Field e (FieldSelection _ x _) ~ e.x - | Field (Expr s a) (FieldSelection s) - -- | > Project e (Left xs) ~ e.{ xs } - -- > Project e (Right t) ~ e.(t) - | Project (Expr s a) (Either [Text] (Expr s a)) - -- | > Assert e ~ assert : e - | Assert (Expr s a) - -- | > Equivalent _ x y ~ x ≡ y - | Equivalent (Maybe CharacterSet) (Expr s a) (Expr s a) - -- | > With x y e ~ x with y = e - | With (Expr s a) (NonEmpty WithComponent) (Expr s a) - -- | > Note s x ~ e - | Note s (Expr s a) - -- | > ImportAlt ~ e1 ? e2 - | ImportAlt (Expr s a) (Expr s a) - -- | > Embed import ~ import - | Embed a - deriving (Foldable, Generic, Traversable, Show, Data, Lift, NFData) --- NB: If you add a constructor to Expr, please also update the Arbitrary --- instance in Dhall.Test.QuickCheck. - --- | This instance encodes what the Dhall standard calls an \"exact match\" --- between two expressions. --- --- Note that --- --- >>> nan = DhallDouble (0/0) --- >>> DoubleLit nan == DoubleLit nan --- True -deriving instance (Eq s, Eq a) => Eq (Expr s a) - --- | Note that this 'Ord' instance inherits `DhallDouble`'s defects. -deriving instance (Ord s, Ord a) => Ord (Expr s a) - --- This instance is hand-written due to the fact that deriving --- it does not give us an INLINABLE pragma. We annotate this fmap --- implementation with this pragma below to allow GHC to, possibly, --- inline the implementation for performance improvements. -instance Functor (Expr s) where - fmap f (Embed a) = Embed (f a) - fmap f (Let b e2) = Let (fmap f b) (fmap f e2) - fmap f (Note s e1) = Note s (fmap f e1) - fmap f (Record a) = Record $ fmap f <$> a - fmap f (RecordLit a) = RecordLit $ fmap f <$> a - fmap f (Lam cs fb e) = Lam cs (f <$> fb) (f <$> e) - fmap f (Field a b) = Field (f <$> a) b - fmap f expression = Lens.over unsafeSubExpressions (fmap f) expression - {-# INLINABLE fmap #-} - -instance Applicative (Expr s) where - pure = Embed - - (<*>) = Control.Monad.ap - -instance Monad (Expr s) where - return = pure - - expression >>= k = case expression of - Embed a -> k a - Let a b -> Let (adaptBinding a) (b >>= k) - Note a b -> Note a (b >>= k) - Record a -> Record $ bindRecordKeyValues <$> a - RecordLit a -> RecordLit $ bindRecordKeyValues <$> a - Lam cs a b -> Lam cs (adaptFunctionBinding a) (b >>= k) - Field a b -> Field (a >>= k) b - _ -> Lens.over unsafeSubExpressions (>>= k) expression - where - bindRecordKeyValues (RecordField s0 e s1 s2) = - RecordField s0 (e >>= k) s1 s2 - - adaptBinding (Binding src0 c src1 d src2 e) = - Binding src0 c src1 (fmap adaptBindingAnnotation d) src2 (e >>= k) - - adaptFunctionBinding (FunctionBinding src0 label src1 src2 type_) = - FunctionBinding src0 label src1 src2 (type_ >>= k) - - adaptBindingAnnotation (src3, f) = (src3, f >>= k) - -instance Bifunctor Expr where - first k (Note a b ) = Note (k a) (first k b) - first _ (Embed a ) = Embed a - first k (Let a b ) = Let (first k a) (first k b) - first k (Record a ) = Record $ first k <$> a - first k (RecordLit a) = RecordLit $ first k <$> a - first k (Lam cs a b ) = Lam cs (first k a) (first k b) - first k (Field a b ) = Field (first k a) (k <$> b) - first k expression = Lens.over unsafeSubExpressions (first k) expression - - second = fmap - -instance IsString (Expr s a) where - fromString str = Var (fromString str) - --- | Generates a syntactically valid Dhall program -instance Pretty a => Pretty (Expr s a) where - pretty = Pretty.unAnnotate . prettyExpr - -{- -Instead of converting explicitly between 'Expr's and 'MultiLet', it might -be nicer to use a pattern synonym: - -> pattern MultiLet' :: NonEmpty (Binding s a) -> Expr s a -> Expr s a -> pattern MultiLet' as b <- (multiLetFromExpr -> Just (MultiLet as b)) where -> MultiLet' as b = wrapInLets as b -> -> multiLetFromExpr :: Expr s a -> Maybe (MultiLet s a) -> multiLetFromExpr = \case -> Let x mA a b -> Just (multiLet x mA a b) -> _ -> Nothing - -This works in principle, but GHC as of v8.8.1 doesn't handle it well: -https://gitlab.haskell.org/ghc/ghc/issues/17096 - -This should be fixed by GHC-8.10, so it might be worth revisiting then. --} - -{-| Generate a 'MultiLet' from the contents of a 'Let'. - - In the resulting @'MultiLet' bs e@, @e@ is guaranteed not to be a 'Let', - but it might be a @('Note' … ('Let' …))@. - - Given parser output, 'multiLet' consolidates @let@s that formed a - let-block in the original source. --} -multiLet :: Binding s a -> Expr s a -> MultiLet s a -multiLet b0 = \case - Let b1 e1 -> - let MultiLet bs e = multiLet b1 e1 - in MultiLet (NonEmpty.cons b0 bs) e - e -> MultiLet (b0 :| []) e - -{-| Wrap let-'Binding's around an 'Expr'. - -'wrapInLets' can be understood as an inverse for 'multiLet': - -> let MultiLet bs e1 = multiLet b e0 -> -> wrapInLets bs e1 == Let b e0 --} -wrapInLets :: Foldable f => f (Binding s a) -> Expr s a -> Expr s a -wrapInLets bs e = foldr Let e bs - -{-| This type represents 1 or more nested `Let` bindings that have been - coalesced together for ease of manipulation --} -data MultiLet s a = MultiLet (NonEmpty (Binding s a)) (Expr s a) - --- | A traversal over the immediate sub-expressions of an expression. -subExpressions - :: Applicative f => (Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a) -subExpressions = subExpressionsWith (pure . Embed) -{-# INLINABLE subExpressions #-} - -{-| A traversal over the immediate sub-expressions of an expression which - allows mapping embedded values --} -subExpressionsWith - :: Applicative f => (a -> f (Expr s b)) -> (Expr s a -> f (Expr s b)) -> Expr s a -> f (Expr s b) -subExpressionsWith h _ (Embed a) = h a -subExpressionsWith _ f (Note a b) = Note a <$> f b -subExpressionsWith _ f (Let a b) = Let <$> bindingExprs f a <*> f b -subExpressionsWith _ f (Record a) = Record <$> traverse (recordFieldExprs f) a -subExpressionsWith _ f (RecordLit a) = RecordLit <$> traverse (recordFieldExprs f) a -subExpressionsWith _ f (Lam cs fb e) = Lam cs <$> functionBindingExprs f fb <*> f e -subExpressionsWith _ f (Field a b) = Field <$> f a <*> pure b -subExpressionsWith _ f expression = unsafeSubExpressions f expression -{-# INLINABLE subExpressionsWith #-} - -{-| An internal utility used to implement transformations that require changing - one of the type variables of the `Expr` type - - This utility only works because the implementation is partial, not - handling the `Let`, `Note`, or `Embed` cases, which need to be handled by - the caller. --} -unsafeSubExpressions - :: Applicative f => (Expr s a -> f (Expr t b)) -> Expr s a -> f (Expr t b) -unsafeSubExpressions _ (Const c) = pure (Const c) -unsafeSubExpressions _ (Var v) = pure (Var v) -unsafeSubExpressions f (Pi cs a b c) = Pi cs a <$> f b <*> f c -unsafeSubExpressions f (App a b) = App <$> f a <*> f b -unsafeSubExpressions f (Annot a b) = Annot <$> f a <*> f b -unsafeSubExpressions _ Bool = pure Bool -unsafeSubExpressions _ (BoolLit b) = pure (BoolLit b) -unsafeSubExpressions f (BoolAnd a b) = BoolAnd <$> f a <*> f b -unsafeSubExpressions f (BoolOr a b) = BoolOr <$> f a <*> f b -unsafeSubExpressions f (BoolEQ a b) = BoolEQ <$> f a <*> f b -unsafeSubExpressions f (BoolNE a b) = BoolNE <$> f a <*> f b -unsafeSubExpressions f (BoolIf a b c) = BoolIf <$> f a <*> f b <*> f c -unsafeSubExpressions _ Natural = pure Natural -unsafeSubExpressions _ (NaturalLit n) = pure (NaturalLit n) -unsafeSubExpressions _ NaturalFold = pure NaturalFold -unsafeSubExpressions _ NaturalBuild = pure NaturalBuild -unsafeSubExpressions _ NaturalIsZero = pure NaturalIsZero -unsafeSubExpressions _ NaturalEven = pure NaturalEven -unsafeSubExpressions _ NaturalOdd = pure NaturalOdd -unsafeSubExpressions _ NaturalToInteger = pure NaturalToInteger -unsafeSubExpressions _ NaturalShow = pure NaturalShow -unsafeSubExpressions _ NaturalSubtract = pure NaturalSubtract -unsafeSubExpressions f (NaturalPlus a b) = NaturalPlus <$> f a <*> f b -unsafeSubExpressions f (NaturalTimes a b) = NaturalTimes <$> f a <*> f b -unsafeSubExpressions _ Integer = pure Integer -unsafeSubExpressions _ (IntegerLit n) = pure (IntegerLit n) -unsafeSubExpressions _ IntegerClamp = pure IntegerClamp -unsafeSubExpressions _ IntegerNegate = pure IntegerNegate -unsafeSubExpressions _ IntegerShow = pure IntegerShow -unsafeSubExpressions _ IntegerToDouble = pure IntegerToDouble -unsafeSubExpressions _ Double = pure Double -unsafeSubExpressions _ (DoubleLit n) = pure (DoubleLit n) -unsafeSubExpressions _ DoubleShow = pure DoubleShow -unsafeSubExpressions _ Text = pure Text -unsafeSubExpressions f (TextLit chunks) = - TextLit <$> chunkExprs f chunks -unsafeSubExpressions f (TextAppend a b) = TextAppend <$> f a <*> f b -unsafeSubExpressions _ TextReplace = pure TextReplace -unsafeSubExpressions _ TextShow = pure TextShow -unsafeSubExpressions _ Date = pure Date -unsafeSubExpressions _ (DateLiteral a) = pure (DateLiteral a) -unsafeSubExpressions _ Time = pure Time -unsafeSubExpressions _ (TimeLiteral a b) = pure (TimeLiteral a b) -unsafeSubExpressions _ TimeZone = pure TimeZone -unsafeSubExpressions _ (TimeZoneLiteral a) = pure (TimeZoneLiteral a) -unsafeSubExpressions _ List = pure List -unsafeSubExpressions f (ListLit a b) = ListLit <$> traverse f a <*> traverse f b -unsafeSubExpressions f (ListAppend a b) = ListAppend <$> f a <*> f b -unsafeSubExpressions _ ListBuild = pure ListBuild -unsafeSubExpressions _ ListFold = pure ListFold -unsafeSubExpressions _ ListLength = pure ListLength -unsafeSubExpressions _ ListHead = pure ListHead -unsafeSubExpressions _ ListLast = pure ListLast -unsafeSubExpressions _ ListIndexed = pure ListIndexed -unsafeSubExpressions _ ListReverse = pure ListReverse -unsafeSubExpressions _ Optional = pure Optional -unsafeSubExpressions f (Some a) = Some <$> f a -unsafeSubExpressions _ None = pure None -unsafeSubExpressions f (Union a) = Union <$> traverse (traverse f) a -unsafeSubExpressions f (Combine cs a b c) = Combine cs a <$> f b <*> f c -unsafeSubExpressions f (CombineTypes cs a b) = CombineTypes cs <$> f a <*> f b -unsafeSubExpressions f (Prefer cs a b c) = Prefer cs <$> a' <*> f b <*> f c - where - a' = case a of - PreferFromSource -> pure PreferFromSource - PreferFromWith d -> PreferFromWith <$> f d - PreferFromCompletion -> pure PreferFromCompletion -unsafeSubExpressions f (RecordCompletion a b) = RecordCompletion <$> f a <*> f b -unsafeSubExpressions f (Merge a b t) = Merge <$> f a <*> f b <*> traverse f t -unsafeSubExpressions f (ToMap a t) = ToMap <$> f a <*> traverse f t -unsafeSubExpressions f (ShowConstructor a) = ShowConstructor <$> f a -unsafeSubExpressions f (Project a b) = Project <$> f a <*> traverse f b -unsafeSubExpressions f (Assert a) = Assert <$> f a -unsafeSubExpressions f (Equivalent cs a b) = Equivalent cs <$> f a <*> f b -unsafeSubExpressions f (With a b c) = With <$> f a <*> pure b <*> f c -unsafeSubExpressions f (ImportAlt l r) = ImportAlt <$> f l <*> f r -unsafeSubExpressions _ (Let {}) = unhandledConstructor "Let" -unsafeSubExpressions _ (Note {}) = unhandledConstructor "Note" -unsafeSubExpressions _ (Embed {}) = unhandledConstructor "Embed" -unsafeSubExpressions _ (Record {}) = unhandledConstructor "Record" -unsafeSubExpressions _ (RecordLit {}) = unhandledConstructor "RecordLit" -unsafeSubExpressions _ (Lam {}) = unhandledConstructor "Lam" -unsafeSubExpressions _ (Field {}) = unhandledConstructor "Field" -{-# INLINABLE unsafeSubExpressions #-} - -unhandledConstructor :: Text -> a -unhandledConstructor constructor = - internalError - ( "Dhall.Syntax.unsafeSubExpressions: Unhandled " - <> constructor - <> " construtor" - ) - -{-| Traverse over the immediate 'Expr' children in a 'Binding'. --} -bindingExprs - :: (Applicative f) - => (Expr s a -> f (Expr s b)) - -> Binding s a -> f (Binding s b) -bindingExprs f (Binding s0 n s1 t s2 v) = - Binding - <$> pure s0 - <*> pure n - <*> pure s1 - <*> traverse (traverse f) t - <*> pure s2 - <*> f v -{-# INLINABLE bindingExprs #-} - -{-| Traverse over the immediate 'Expr' children in a 'RecordField'. --} -recordFieldExprs - :: Applicative f - => (Expr s a -> f (Expr s b)) - -> RecordField s a -> f (RecordField s b) -recordFieldExprs f (RecordField s0 e s1 s2) = - RecordField - <$> pure s0 - <*> f e - <*> pure s1 - <*> pure s2 -{-# INLINABLE recordFieldExprs #-} - -{-| Traverse over the immediate 'Expr' children in a 'FunctionBinding'. --} -functionBindingExprs - :: Applicative f - => (Expr s a -> f (Expr s b)) - -> FunctionBinding s a -> f (FunctionBinding s b) -functionBindingExprs f (FunctionBinding s0 label s1 s2 type_) = - FunctionBinding - <$> pure s0 - <*> pure label - <*> pure s1 - <*> pure s2 - <*> f type_ -{-# INLINABLE functionBindingExprs #-} - --- | A traversal over the immediate sub-expressions in 'Chunks'. -chunkExprs - :: Applicative f - => (Expr s a -> f (Expr t b)) - -> Chunks s a -> f (Chunks t b) -chunkExprs f (Chunks chunks final) = - flip Chunks final <$> traverse (traverse f) chunks -{-# INLINABLE chunkExprs #-} - -{-| Internal representation of a directory that stores the path components in - reverse order - - In other words, the directory @\/foo\/bar\/baz@ is encoded as - @Directory { components = [ "baz", "bar", "foo" ] }@ --} -newtype Directory = Directory { components :: [Text] } - deriving stock (Eq, Generic, Ord, Show) - deriving anyclass NFData - -instance Semigroup Directory where - Directory components₀ <> Directory components₁ = - Directory (components₁ <> components₀) - -instance Pretty Directory where - pretty (Directory {..}) = foldMap prettyPathComponent (reverse components) - -prettyPathComponent :: Text -> Doc ann -prettyPathComponent text - | Data.Text.all pathCharacter text = - "/" <> Pretty.pretty text - | otherwise = - "/\"" <> Pretty.pretty text <> "\"" - -{-| A `File` is a `directory` followed by one additional path component - representing the `file` name --} -data File = File - { directory :: Directory - , file :: Text - } deriving (Eq, Generic, Ord, Show, NFData) - -instance Pretty File where - pretty (File {..}) = - Pretty.pretty directory - <> prettyPathComponent file - -instance Semigroup File where - File directory₀ _ <> File directory₁ file = - File (directory₀ <> directory₁) file - --- | The beginning of a file path which anchors subsequent path components -data FilePrefix - = Absolute - -- ^ Absolute path - | Here - -- ^ Path relative to @.@ - | Parent - -- ^ Path relative to @..@ - | Home - -- ^ Path relative to @~@ - deriving (Eq, Generic, Ord, Show, NFData) - -instance Pretty FilePrefix where - pretty Absolute = "" - pretty Here = "." - pretty Parent = ".." - pretty Home = "~" - --- | The URI scheme -data Scheme = HTTP | HTTPS deriving (Eq, Generic, Ord, Show, NFData) - --- | This type stores all of the components of a remote import -data URL = URL - { scheme :: Scheme - , authority :: Text - , path :: File - , query :: Maybe Text - , headers :: Maybe (Expr Src Import) - } deriving (Eq, Generic, Ord, Show, NFData) - -instance Pretty URL where - pretty (URL {..}) = - schemeDoc - <> "://" - <> Pretty.pretty authority - <> pathDoc - <> queryDoc - <> foldMap prettyHeaders headers - where - prettyHeaders h = - " using (" <> Pretty.unAnnotate (Pretty.pretty h) <> ")" - - File {..} = path - - Directory {..} = directory - - pathDoc = - foldMap prettyURIComponent (reverse components) - <> prettyURIComponent file - - schemeDoc = case scheme of - HTTP -> "http" - HTTPS -> "https" - - queryDoc = case query of - Nothing -> "" - Just q -> "?" <> Pretty.pretty q - -prettyURIComponent :: Text -> Doc ann -prettyURIComponent text = - Pretty.pretty $ URI.normalizeCase $ URI.normalizeEscape $ "/" <> Data.Text.unpack text - --- | The type of import (i.e. local vs. remote vs. environment) -data ImportType - = Local FilePrefix File - -- ^ Local path - | Remote URL - -- ^ URL of remote resource and optional headers stored in an import - | Env Text - -- ^ Environment variable - | Missing - deriving (Eq, Generic, Ord, Show, NFData) - -parent :: File -parent = File { directory = Directory { components = [ ".." ] }, file = "" } - -instance Semigroup ImportType where - Local prefix file₀ <> Local Here file₁ = Local prefix (file₀ <> file₁) - - Remote (URL { path = path₀, ..}) <> Local Here path₁ = - Remote (URL { path = path₀ <> path₁, ..}) - - Local prefix file₀ <> Local Parent file₁ = - Local prefix (file₀ <> parent <> file₁) - - Remote (URL { path = path₀, .. }) <> Local Parent path₁ = - Remote (URL { path = path₀ <> parent <> path₁, .. }) - - import₀ <> Remote (URL { headers = headers₀, .. }) = - Remote (URL { headers = headers₁, .. }) - where - importHashed₀ = Import (ImportHashed Nothing import₀) Code - - headers₁ = fmap (fmap (importHashed₀ <>)) headers₀ - - _ <> import₁ = - import₁ - -instance Pretty ImportType where - pretty (Local prefix file) = - Pretty.pretty prefix <> Pretty.pretty file - - pretty (Remote url) = Pretty.pretty url - - pretty (Env env) = "env:" <> prettyEnvironmentVariable env - - pretty Missing = "missing" - --- | How to interpret the import's contents (i.e. as Dhall code or raw text) -data ImportMode = Code | RawText | Location - deriving (Eq, Generic, Ord, Show, NFData) - --- | A `ImportType` extended with an optional hash for semantic integrity checks -data ImportHashed = ImportHashed - { hash :: Maybe Dhall.Crypto.SHA256Digest - , importType :: ImportType - } deriving (Eq, Generic, Ord, Show, NFData) - -instance Semigroup ImportHashed where - ImportHashed _ importType₀ <> ImportHashed hash importType₁ = - ImportHashed hash (importType₀ <> importType₁) - -instance Pretty ImportHashed where - pretty (ImportHashed Nothing p) = - Pretty.pretty p - pretty (ImportHashed (Just h) p) = - Pretty.group (Pretty.flatAlt long short) - where - long = - Pretty.align - ( Pretty.pretty p <> Pretty.hardline - <> " sha256:" <> Pretty.pretty (show h) - ) - - short = Pretty.pretty p <> " sha256:" <> Pretty.pretty (show h) - --- | Reference to an external resource -data Import = Import - { importHashed :: ImportHashed - , importMode :: ImportMode - } deriving (Eq, Generic, Ord, Show, NFData) - -instance Semigroup Import where - Import importHashed₀ _ <> Import importHashed₁ code = - Import (importHashed₀ <> importHashed₁) code - -instance Pretty Import where - pretty (Import {..}) = Pretty.pretty importHashed <> Pretty.pretty suffix - where - suffix :: Text - suffix = case importMode of - RawText -> " as Text" - Location -> " as Location" - Code -> "" - -{-| Returns `True` if the given `Char` is valid within an unquoted path - component - - This is exported for reuse within the @"Dhall.Parser.Token"@ module --} -pathCharacter :: Char -> Bool -pathCharacter c = - '\x21' == c - || ('\x24' <= c && c <= '\x27') - || ('\x2A' <= c && c <= '\x2B') - || ('\x2D' <= c && c <= '\x2E') - || ('\x30' <= c && c <= '\x3B') - || c == '\x3D' - || ('\x40' <= c && c <= '\x5A') - || ('\x5E' <= c && c <= '\x7A') - || c == '\x7C' - || c == '\x7E' - --- | Remove all `Note` constructors from an `Expr` (i.e. de-`Note`) --- --- This also remove CharacterSet annotations. -denote :: Expr s a -> Expr t a -denote = \case - Note _ b -> denote b - Let a b -> Let (denoteBinding a) (denote b) - Embed a -> Embed a - Combine _ _ b c -> Combine Nothing Nothing (denote b) (denote c) - CombineTypes _ b c -> CombineTypes Nothing (denote b) (denote c) - Prefer _ a b c -> Lens.over unsafeSubExpressions denote $ Prefer Nothing a b c - Record a -> Record $ denoteRecordField <$> a - RecordLit a -> RecordLit $ denoteRecordField <$> a - Lam _ a b -> Lam Nothing (denoteFunctionBinding a) (denote b) - Pi _ t a b -> Pi Nothing t (denote a) (denote b) - Field a (FieldSelection _ b _) -> Field (denote a) (FieldSelection Nothing b Nothing) - Equivalent _ a b -> Equivalent Nothing (denote a) (denote b) - expression -> Lens.over unsafeSubExpressions denote expression - where - denoteRecordField (RecordField _ e _ _) = RecordField Nothing (denote e) Nothing Nothing - denoteBinding (Binding _ c _ d _ e) = - Binding Nothing c Nothing (fmap denoteBindingAnnotation d) Nothing (denote e) - - denoteBindingAnnotation (_, f) = (Nothing, denote f) - - denoteFunctionBinding (FunctionBinding _ l _ _ t) = - FunctionBinding Nothing l Nothing Nothing (denote t) - --- | The \"opposite\" of `denote`, like @first absurd@ but faster -renote :: Expr Void a -> Expr s a -renote = unsafeCoerce -{-# INLINE renote #-} - -{-| Remove any outermost `Note` constructors - - This is typically used when you want to get the outermost non-`Note` - constructor without removing internal `Note` constructors --} -shallowDenote :: Expr s a -> Expr s a -shallowDenote (Note _ e) = shallowDenote e -shallowDenote e = e - --- | The set of reserved keywords according to the @keyword@ rule in the grammar -reservedKeywords :: HashSet Text -reservedKeywords = - Data.HashSet.fromList - [ "if" - , "then" - , "else" - , "let" - , "in" - , "using" - , "missing" - , "as" - , "Infinity" - , "NaN" - , "merge" - , "Some" - , "toMap" - , "assert" - , "forall" - , "with" - ] - --- | The set of reserved identifiers for the Dhall language --- | Contains also all keywords from "reservedKeywords" -reservedIdentifiers :: HashSet Text -reservedIdentifiers = reservedKeywords <> - Data.HashSet.fromList - [ -- Builtins according to the `builtin` rule in the grammar - "Natural/fold" - , "Natural/build" - , "Natural/isZero" - , "Natural/even" - , "Natural/odd" - , "Natural/toInteger" - , "Natural/show" - , "Natural/subtract" - , "Integer" - , "Integer/clamp" - , "Integer/negate" - , "Integer/show" - , "Integer/toDouble" - , "Integer/show" - , "Natural/subtract" - , "Double/show" - , "List/build" - , "List/fold" - , "List/length" - , "List/head" - , "List/last" - , "List/indexed" - , "List/reverse" - , "Text/replace" - , "Text/show" - , "Bool" - , "True" - , "False" - , "Optional" - , "None" - , "Natural" - , "Integer" - , "Double" - , "Text" - , "Date" - , "Time" - , "TimeZone" - , "List" - , "Type" - , "Kind" - , "Sort" - ] - --- | Same as @Data.Text.splitOn@, except always returning a `NonEmpty` result -splitOn :: Text -> Text -> NonEmpty Text -splitOn needle haystack = - case Data.Text.splitOn needle haystack of - [] -> "" :| [] - t : ts -> t :| ts - --- | Split `Chunks` by lines -linesLiteral :: Chunks s a -> NonEmpty (Chunks s a) -linesLiteral (Chunks [] suffix) = - fmap (Chunks []) (splitOn "\n" suffix) -linesLiteral (Chunks ((prefix, interpolation) : pairs₀) suffix₀) = - foldr - NonEmpty.cons - (Chunks ((lastLine, interpolation) : pairs₁) suffix₁ :| chunks) - (fmap (Chunks []) initLines) - where - splitLines = splitOn "\n" prefix - - initLines = NonEmpty.init splitLines - lastLine = NonEmpty.last splitLines - - Chunks pairs₁ suffix₁ :| chunks = linesLiteral (Chunks pairs₀ suffix₀) - --- | Flatten several `Chunks` back into a single `Chunks` by inserting newlines -unlinesLiteral :: NonEmpty (Chunks s a) -> Chunks s a -unlinesLiteral chunks = - Data.Foldable.fold (NonEmpty.intersperse "\n" chunks) - --- | Returns `True` if the `Chunks` represents a blank line -emptyLine :: Chunks s a -> Bool -emptyLine (Chunks [] "" ) = True -emptyLine (Chunks [] "\r") = True -- So that `\r\n` is treated as a blank line -emptyLine _ = False - --- | Return the leading whitespace for a `Chunks` literal -leadingSpaces :: Chunks s a -> Text -leadingSpaces chunks = Data.Text.takeWhile isSpace firstText - where - isSpace c = c == ' ' || c == '\t' - - firstText = - case chunks of - Chunks [] suffix -> suffix - Chunks ((prefix, _) : _ ) _ -> prefix - -{-| Compute the longest shared whitespace prefix for the purposes of stripping - leading indentation --} -longestSharedWhitespacePrefix :: NonEmpty (Chunks s a) -> Text -longestSharedWhitespacePrefix literals = - case fmap leadingSpaces filteredLines of - l : ls -> Data.Foldable.foldl' sharedPrefix l ls - [] -> "" - where - sharedPrefix ab ac = - case Data.Text.commonPrefixes ab ac of - Just (a, _b, _c) -> a - Nothing -> "" - - -- The standard specifies to filter out blank lines for all lines *except* - -- for the last line - filteredLines = newInit <> pure oldLast - where - oldInit = NonEmpty.init literals - - oldLast = NonEmpty.last literals - - newInit = filter (not . emptyLine) oldInit - --- | Drop the first @n@ characters for a `Chunks` literal -dropLiteral :: Int -> Chunks s a -> Chunks s a -dropLiteral n (Chunks [] suffix) = - Chunks [] (Data.Text.drop n suffix) -dropLiteral n (Chunks ((prefix, interpolation) : rest) suffix) = - Chunks ((Data.Text.drop n prefix, interpolation) : rest) suffix - -{-| Convert a single-quoted `Chunks` literal to the equivalent double-quoted - `Chunks` literal --} -toDoubleQuoted :: Chunks Src a -> Chunks Src a -toDoubleQuoted literal = - unlinesLiteral (fmap (dropLiteral indent) literals) - where - literals = linesLiteral literal - - longestSharedPrefix = longestSharedWhitespacePrefix literals - - indent = Data.Text.length longestSharedPrefix - -{-| `shift` is used by both normalization and type-checking to avoid variable - capture by shifting variable indices - - For example, suppose that you were to normalize the following expression: - -> λ(a : Type) → λ(x : a) → (λ(y : a) → λ(x : a) → y) x - - If you were to substitute @y@ with @x@ without shifting any variable - indices, then you would get the following incorrect result: - -> λ(a : Type) → λ(x : a) → λ(x : a) → x -- Incorrect normalized form - - In order to substitute @x@ in place of @y@ we need to `shift` @x@ by @1@ in - order to avoid being misinterpreted as the @x@ bound by the innermost - lambda. If we perform that `shift` then we get the correct result: - -> λ(a : Type) → λ(x : a) → λ(x : a) → x@1 - - As a more worked example, suppose that you were to normalize the following - expression: - -> λ(a : Type) -> → λ(f : a → a → a) -> → λ(x : a) -> → λ(x : a) -> → (λ(x : a) → f x x@1) x@1 - - The correct normalized result would be: - -> λ(a : Type) -> → λ(f : a → a → a) -> → λ(x : a) -> → λ(x : a) -> → f x@1 x - - The above example illustrates how we need to both increase and decrease - variable indices as part of substitution: - - * We need to increase the index of the outer @x\@1@ to @x\@2@ before we - substitute it into the body of the innermost lambda expression in order - to avoid variable capture. This substitution changes the body of the - lambda expression to @(f x\@2 x\@1)@ - - * We then remove the innermost lambda and therefore decrease the indices of - both @x@s in @(f x\@2 x\@1)@ to @(f x\@1 x)@ in order to reflect that one - less @x@ variable is now bound within that scope - - Formally, @(shift d (V x n) e)@ modifies the expression @e@ by adding @d@ to - the indices of all variables named @x@ whose indices are greater than - @(n + m)@, where @m@ is the number of bound variables of the same name - within that scope - - In practice, @d@ is always @1@ or @-1@ because we either: - - * increment variables by @1@ to avoid variable capture during substitution - * decrement variables by @1@ when deleting lambdas after substitution - - @n@ starts off at @0@ when substitution begins and increments every time we - descend into a lambda or let expression that binds a variable of the same - name in order to avoid shifting the bound variables by mistake. --} -shift :: Int -> Var -> Expr s a -> Expr s a -shift d (V x n) (Var (V x' n')) = Var (V x' n'') - where - n'' = if x == x' && n <= n' then n' + d else n' -shift d (V x n) (Lam cs (FunctionBinding src0 x' src1 src2 _A) b) = - Lam cs (FunctionBinding src0 x' src1 src2 _A') b' - where - _A' = shift d (V x n ) _A - b' = shift d (V x n') b - where - n' = if x == x' then n + 1 else n -shift d (V x n) (Pi cs x' _A _B) = Pi cs x' _A' _B' - where - _A' = shift d (V x n ) _A - _B' = shift d (V x n') _B - where - n' = if x == x' then n + 1 else n -shift d (V x n) (Let (Binding src0 f src1 mt src2 r) e) = - Let (Binding src0 f src1 mt' src2 r') e' - where - e' = shift d (V x n') e - where - n' = if x == f then n + 1 else n - - mt' = fmap (fmap (shift d (V x n))) mt - r' = shift d (V x n) r -shift d v expression = Lens.over subExpressions (shift d v) expression - -_ERROR :: String -_ERROR = "\ESC[1;31mError\ESC[0m" - -{-| Utility function used to throw internal errors that should never happen - (in theory) but that are not enforced by the type system --} -internalError :: Data.Text.Text -> forall b . b -internalError text = error (unlines - [ _ERROR <> ": Compiler bug " - , " " - , "Explanation: This error message means that there is a bug in the Dhall compiler." - , "You didn't do anything wrong, but if you would like to see this problem fixed " - , "then you should report the bug at: " - , " " - , "https://github.com/dhall-lang/dhall-haskell/issues " - , " " - , "Please include the following text in your bug report: " - , " " - , "``` " - , Data.Text.unpack text <> " " - , "``` " - ] ) +import Dhall.Syntax.Instances.Applicative as Export () +import Dhall.Syntax.Instances.Bifunctor as Export () +import Dhall.Syntax.Instances.Data as Export () +import Dhall.Syntax.Instances.Eq as Export () +import Dhall.Syntax.Instances.Foldable as Export () +import Dhall.Syntax.Instances.Functor as Export () +import Dhall.Syntax.Instances.Lift as Export () +import Dhall.Syntax.Instances.Monad as Export () +import Dhall.Syntax.Instances.Monoid as Export () +import Dhall.Syntax.Instances.NFData as Export () +import Dhall.Syntax.Instances.Ord as Export () +import Dhall.Syntax.Instances.Pretty as Export +import Dhall.Syntax.Instances.Semigroup as Export () +import Dhall.Syntax.Instances.Show as Export () +import Dhall.Syntax.Instances.Traversable as Export () +import Dhall.Syntax.Operations as Export +import Dhall.Syntax.Types as Export diff --git a/dhall/src/Dhall/Syntax/Instances/Applicative.hs b/dhall/src/Dhall/Syntax/Instances/Applicative.hs new file mode 100644 index 000000000..9c6392e13 --- /dev/null +++ b/dhall/src/Dhall/Syntax/Instances/Applicative.hs @@ -0,0 +1,32 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Dhall.Syntax.Instances.Applicative () where + +import Dhall.Syntax.Operations +import Dhall.Syntax.Types + +import qualified Lens.Family as Lens + +instance Applicative (Expr s) where + pure = Embed + + expression <*> k = case expression of + Embed a -> a <$> k + Let a b -> Let (adaptBinding a) (b <*> k) + Note a b -> Note a (b <*> k) + Record a -> Record $ adaptRecordField <$> a + RecordLit a -> RecordLit $ adaptRecordField <$> a + Lam cs a b -> Lam cs (adaptFunctionBinding a) (b <*> k) + Field a b -> Field (a <*> k) b + _ -> Lens.over unsafeSubExpressions (<*> k) expression + where + adaptRecordField (RecordField s0 e s1 s2) = + RecordField s0 (e <*> k) s1 s2 + + adaptBinding (Binding src0 c src1 d src2 e) = + Binding src0 c src1 (fmap adaptBindingAnnotation d) src2 (e <*> k) + + adaptFunctionBinding (FunctionBinding src0 label src1 src2 type_) = + FunctionBinding src0 label src1 src2 (type_ <*> k) + + adaptBindingAnnotation (src3, f) = (src3, f <*> k) diff --git a/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs b/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs new file mode 100644 index 000000000..97a688e56 --- /dev/null +++ b/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs @@ -0,0 +1,47 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Dhall.Syntax.Instances.Bifunctor () where + +import Data.Bifunctor (Bifunctor (..)) +import Dhall.Syntax.Operations +import Dhall.Syntax.Types + +import qualified Lens.Family as Lens + +instance Bifunctor Binding where + first k (Binding src0 a src1 b src2 c) = + Binding (fmap k src0) a (fmap k src1) (fmap adapt0 b) (fmap k src2) (first k c) + where + adapt0 (src3, d) = (fmap k src3, first k d) + + second = fmap + +instance Bifunctor PreferAnnotation where + first _ PreferFromSource = PreferFromSource + first f (PreferFromWith e ) = PreferFromWith (first f e) + first _ PreferFromCompletion = PreferFromCompletion + + second = fmap + +instance Bifunctor RecordField where + first k (RecordField s0 value' s1 s2) = + RecordField (k <$> s0) (first k value') (k <$> s1) (k <$> s2) + second = fmap + +instance Bifunctor FunctionBinding where + first k (FunctionBinding src0 label src1 src2 type_) = + FunctionBinding (k <$> src0) label (k <$> src1) (k <$> src2) (first k type_) + + second = fmap + +instance Bifunctor Expr where + first k (Note a b ) = Note (k a) (first k b) + first _ (Embed a ) = Embed a + first k (Let a b ) = Let (first k a) (first k b) + first k (Record a ) = Record $ first k <$> a + first k (RecordLit a) = RecordLit $ first k <$> a + first k (Lam cs a b ) = Lam cs (first k a) (first k b) + first k (Field a b ) = Field (first k a) (k <$> b) + first k expression = Lens.over unsafeSubExpressions (first k) expression + + second = fmap diff --git a/dhall/src/Dhall/Syntax/Instances/Data.hs b/dhall/src/Dhall/Syntax/Instances/Data.hs new file mode 100644 index 000000000..d9e1788f0 --- /dev/null +++ b/dhall/src/Dhall/Syntax/Instances/Data.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Dhall.Syntax.Instances.Data () where + +import Data.Data (Data) +import Dhall.Syntax.Types + +deriving instance Data Const +deriving instance Data Var +deriving instance (Data a, Data s) => Data (Binding s a) +deriving instance Data DhallDouble +deriving instance (Data a, Data s) => Data (Chunks s a) +deriving instance (Data a, Data s) => Data (PreferAnnotation s a) +deriving instance (Data a, Data s) => Data (RecordField s a) +deriving instance (Data a, Data s) => Data (FunctionBinding s a) +deriving instance Data s => Data (FieldSelection s) +deriving instance Data WithComponent +deriving instance (Data a, Data s) => Data (Expr s a) diff --git a/dhall/src/Dhall/Syntax/Instances/Eq.hs b/dhall/src/Dhall/Syntax/Instances/Eq.hs new file mode 100644 index 000000000..c4c376b18 --- /dev/null +++ b/dhall/src/Dhall/Syntax/Instances/Eq.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Dhall.Syntax.Instances.Eq () where + +import Data.Bits (xor) +import Dhall.Syntax.Types + +deriving instance Eq Const +deriving instance Eq Var +deriving instance (Eq s, Eq a) => Eq (Binding s a) +deriving instance (Eq s, Eq a) => Eq (Chunks s a) +deriving instance (Eq s, Eq a) => Eq (PreferAnnotation s a) +deriving instance (Eq s, Eq a) => Eq (RecordField s a) +deriving instance (Eq s, Eq a) => Eq (FunctionBinding s a) +deriving instance Eq s => Eq (FieldSelection s) +deriving instance Eq WithComponent +-- | This instance encodes what the Dhall standard calls an \"exact match\" +-- between two expressions. +-- +-- Note that +-- +-- >>> nan = DhallDouble (0/0) +-- >>> DoubleLit nan == DoubleLit nan +-- True +deriving instance (Eq s, Eq a) => Eq (Expr s a) +deriving instance Eq Directory +deriving instance Eq File +deriving instance Eq FilePrefix +deriving instance Eq Scheme +deriving instance Eq URL +deriving instance Eq ImportType +deriving instance Eq ImportMode +deriving instance Eq ImportHashed +deriving instance Eq Import + +-- | This instance satisfies all the customary 'Eq' laws except substitutivity. +-- +-- In particular: +-- +-- >>> nan = DhallDouble (0/0) +-- >>> nan == nan +-- True +-- +-- This instance is also consistent with with the binary encoding of Dhall @Double@s: +-- +-- >>> toBytes n = Dhall.Binary.encodeExpression (DoubleLit n :: Expr Void Import) +-- +-- prop> \a b -> (a == b) == (toBytes a == toBytes b) +instance Eq DhallDouble where + DhallDouble a == DhallDouble b + | isNaN a && isNaN b = True + | isNegativeZero a `xor` isNegativeZero b = False + | otherwise = a == b diff --git a/dhall/src/Dhall/Syntax/Instances/Foldable.hs b/dhall/src/Dhall/Syntax/Instances/Foldable.hs new file mode 100644 index 000000000..4827ef2ed --- /dev/null +++ b/dhall/src/Dhall/Syntax/Instances/Foldable.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Dhall.Syntax.Instances.Foldable () where + +import Dhall.Syntax.Types + +deriving instance Foldable (Binding s) +deriving instance Foldable (Chunks s) +deriving instance Foldable (PreferAnnotation s) +deriving instance Foldable (RecordField s) +deriving instance Foldable (FunctionBinding s) +deriving instance Foldable FieldSelection +deriving instance Foldable (Expr s) diff --git a/dhall/src/Dhall/Syntax/Instances/Functor.hs b/dhall/src/Dhall/Syntax/Instances/Functor.hs new file mode 100644 index 000000000..a5c00e4de --- /dev/null +++ b/dhall/src/Dhall/Syntax/Instances/Functor.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Dhall.Syntax.Instances.Functor () where + +import {-# SOURCE #-} Dhall.Syntax.Operations (unsafeSubExpressions) +import Dhall.Syntax.Types + +import qualified Lens.Family as Lens + +deriving instance Functor (Binding s) +deriving instance Functor (Chunks s) +deriving instance Functor (PreferAnnotation s) +deriving instance Functor (RecordField s) +deriving instance Functor (FunctionBinding s) +deriving instance Functor FieldSelection + +-- This instance is hand-written due to the fact that deriving +-- it does not give us an INLINABLE pragma. We annotate this fmap +-- implementation with this pragma below to allow GHC to, possibly, +-- inline the implementation for performance improvements. +instance Functor (Expr s) where + fmap f (Embed a) = Embed (f a) + fmap f (Let b e2) = Let (fmap f b) (fmap f e2) + fmap f (Note s e1) = Note s (fmap f e1) + fmap f (Record a) = Record $ fmap f <$> a + fmap f (RecordLit a) = RecordLit $ fmap f <$> a + fmap f (Lam cs fb e) = Lam cs (f <$> fb) (f <$> e) + fmap f (Field a b) = Field (f <$> a) b + fmap f expression = Lens.over unsafeSubExpressions (fmap f) expression + {-# INLINABLE fmap #-} diff --git a/dhall/src/Dhall/Syntax/Instances/Lift.hs b/dhall/src/Dhall/Syntax/Instances/Lift.hs new file mode 100644 index 000000000..9d35d1038 --- /dev/null +++ b/dhall/src/Dhall/Syntax/Instances/Lift.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Dhall.Syntax.Instances.Lift () where + +import Dhall.Syntax.Types +import Language.Haskell.TH.Syntax (Lift) + +import qualified Data.Fixed as Fixed +import qualified Data.Time as Time + +deriving instance Lift Time.Day +deriving instance Lift Time.TimeOfDay +deriving instance Lift Time.TimeZone +deriving instance Lift (Fixed.Fixed a) +deriving instance Lift Const +deriving instance Lift Var +deriving instance (Lift s, Lift a) => Lift (Binding s a) +deriving instance Lift DhallDouble +deriving instance (Lift s, Lift a) => Lift (Chunks s a) +deriving instance (Lift s, Lift a) => Lift (PreferAnnotation s a) +deriving instance (Lift s, Lift a) => Lift (RecordField s a) +deriving instance (Lift s, Lift a) => Lift (FunctionBinding s a) +deriving instance Lift s => Lift (FieldSelection s) +deriving instance Lift WithComponent +deriving instance (Lift s, Lift a) => Lift (Expr s a) diff --git a/dhall/src/Dhall/Syntax/Instances/Monad.hs b/dhall/src/Dhall/Syntax/Instances/Monad.hs new file mode 100644 index 000000000..bf486c82d --- /dev/null +++ b/dhall/src/Dhall/Syntax/Instances/Monad.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Dhall.Syntax.Instances.Monad () where + +import Dhall.Syntax.Instances.Applicative () +import Dhall.Syntax.Types + +import qualified Control.Monad + +instance Monad (Expr s) where + return = pure + + expression >>= k = Control.Monad.join $ pure k <*> expression diff --git a/dhall/src/Dhall/Syntax/Instances/Monoid.hs b/dhall/src/Dhall/Syntax/Instances/Monoid.hs new file mode 100644 index 000000000..059dbd40b --- /dev/null +++ b/dhall/src/Dhall/Syntax/Instances/Monoid.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Dhall.Syntax.Instances.Monoid () where + +import Dhall.Syntax.Instances.Semigroup () +import Dhall.Syntax.Types + +instance Monoid (Chunks s a) where + mempty = Chunks [] mempty diff --git a/dhall/src/Dhall/Syntax/Instances/NFData.hs b/dhall/src/Dhall/Syntax/Instances/NFData.hs new file mode 100644 index 000000000..f7a413263 --- /dev/null +++ b/dhall/src/Dhall/Syntax/Instances/NFData.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Dhall.Syntax.Instances.NFData () where + +import Control.DeepSeq (NFData) +import Dhall.Syntax.Types + +instance NFData Const +instance NFData Var +instance (NFData s, NFData a) => NFData (Binding s a) +instance NFData DhallDouble +instance (NFData s, NFData a) => NFData (Chunks s a) +instance (NFData s, NFData a) => NFData (PreferAnnotation s a) +instance (NFData s, NFData a) => NFData (RecordField s a) +instance (NFData s, NFData a) => NFData (FunctionBinding s a) +instance NFData s => NFData (FieldSelection s) +instance NFData WithComponent +instance (NFData s, NFData a) => NFData (Expr s a) +instance NFData Directory +instance NFData File +instance NFData FilePrefix +instance NFData Scheme +instance NFData URL +instance NFData ImportType +instance NFData ImportMode +instance NFData ImportHashed +instance NFData Import diff --git a/dhall/src/Dhall/Syntax/Instances/Ord.hs b/dhall/src/Dhall/Syntax/Instances/Ord.hs new file mode 100644 index 000000000..4daccd29e --- /dev/null +++ b/dhall/src/Dhall/Syntax/Instances/Ord.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Dhall.Syntax.Instances.Ord () where + +import Dhall.Syntax.Instances.Eq () +import Dhall.Syntax.Types + +deriving instance Ord Const +deriving instance Ord Var +deriving instance (Ord s, Ord a) => Ord (Binding s a) +deriving instance (Ord s, Ord a) => Ord (Chunks s a) +deriving instance (Ord s, Ord a) => Ord (PreferAnnotation s a) +deriving instance (Ord s, Ord a) => Ord (RecordField s a) +deriving instance (Ord s, Ord a) => Ord (FunctionBinding s a) +deriving instance Ord s => Ord (FieldSelection s) +deriving instance Ord WithComponent +-- | Note that this 'Ord' instance inherits `DhallDouble`'s defects. +deriving instance (Ord s, Ord a) => Ord (Expr s a) +deriving instance Ord Directory +deriving instance Ord File +deriving instance Ord FilePrefix +deriving instance Ord Scheme +deriving instance Ord URL +deriving instance Ord ImportType +deriving instance Ord ImportMode +deriving instance Ord ImportHashed +deriving instance Ord Import + +-- | This instance relies on the 'Eq' instance for 'DhallDouble' but cannot +-- satisfy the customary 'Ord' laws when @NaN@ is involved. +instance Ord DhallDouble where + compare a@(DhallDouble a') b@(DhallDouble b') = + if a == b + then EQ + else compare a' b' diff --git a/dhall/src/Dhall/Syntax/Instances/Pretty.hs b/dhall/src/Dhall/Syntax/Instances/Pretty.hs new file mode 100644 index 000000000..e8e19e18e --- /dev/null +++ b/dhall/src/Dhall/Syntax/Instances/Pretty.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Dhall.Syntax.Instances.Pretty + ( pathCharacter + ) where + +import Data.Text (Text) +import {-# SOURCE #-} Dhall.Pretty.Internal +import Dhall.Syntax.Types +import Prettyprinter (Doc, Pretty) + +import qualified Data.Text +import qualified Network.URI as URI +import qualified Prettyprinter as Pretty + +instance Pretty Const where + pretty = Pretty.unAnnotate . prettyConst + +instance Pretty Var where + pretty = Pretty.unAnnotate . prettyVar + +-- | Generates a syntactically valid Dhall program +instance Pretty a => Pretty (Expr s a) where + pretty = Pretty.unAnnotate . prettyExpr + +instance Pretty Directory where + pretty (Directory {..}) = foldMap prettyPathComponent (reverse components) + +prettyPathComponent :: Text -> Doc ann +prettyPathComponent text + | Data.Text.all pathCharacter text = + "/" <> Pretty.pretty text + | otherwise = + "/\"" <> Pretty.pretty text <> "\"" + +instance Pretty File where + pretty (File {..}) = + Pretty.pretty directory + <> prettyPathComponent file + +instance Pretty FilePrefix where + pretty Absolute = "" + pretty Here = "." + pretty Parent = ".." + pretty Home = "~" + +instance Pretty URL where + pretty (URL {..}) = + schemeDoc + <> "://" + <> Pretty.pretty authority + <> pathDoc + <> queryDoc + <> foldMap prettyHeaders headers + where + prettyHeaders h = + " using (" <> Pretty.unAnnotate (Pretty.pretty h) <> ")" + + File {..} = path + + Directory {..} = directory + + pathDoc = + foldMap prettyURIComponent (reverse components) + <> prettyURIComponent file + + schemeDoc = case scheme of + HTTP -> "http" + HTTPS -> "https" + + queryDoc = case query of + Nothing -> "" + Just q -> "?" <> Pretty.pretty q + +prettyURIComponent :: Text -> Doc ann +prettyURIComponent text = + Pretty.pretty $ URI.normalizeCase $ URI.normalizeEscape $ "/" <> Data.Text.unpack text + +instance Pretty ImportType where + pretty (Local prefix file) = + Pretty.pretty prefix <> Pretty.pretty file + + pretty (Remote url) = Pretty.pretty url + + pretty (Env env) = "env:" <> prettyEnvironmentVariable env + + pretty Missing = "missing" + +instance Pretty ImportHashed where + pretty (ImportHashed Nothing p) = + Pretty.pretty p + pretty (ImportHashed (Just h) p) = + Pretty.group (Pretty.flatAlt long short) + where + long = + Pretty.align + ( Pretty.pretty p <> Pretty.hardline + <> " sha256:" <> Pretty.pretty (show h) + ) + + short = Pretty.pretty p <> " sha256:" <> Pretty.pretty (show h) + +instance Pretty Import where + pretty (Import {..}) = Pretty.pretty importHashed <> Pretty.pretty suffix + where + suffix :: Text + suffix = case importMode of + RawText -> " as Text" + Location -> " as Location" + Code -> "" + +{-| Returns `True` if the given `Char` is valid within an unquoted path + component + + This is exported for reuse within the @"Dhall.Parser.Token"@ module +-} +pathCharacter :: Char -> Bool +pathCharacter c = + '\x21' == c + || ('\x24' <= c && c <= '\x27') + || ('\x2A' <= c && c <= '\x2B') + || ('\x2D' <= c && c <= '\x2E') + || ('\x30' <= c && c <= '\x3B') + || c == '\x3D' + || ('\x40' <= c && c <= '\x5A') + || ('\x5E' <= c && c <= '\x7A') + || c == '\x7C' + || c == '\x7E' diff --git a/dhall/src/Dhall/Syntax/Instances/Pretty.hs-boot b/dhall/src/Dhall/Syntax/Instances/Pretty.hs-boot new file mode 100644 index 000000000..8c68dc993 --- /dev/null +++ b/dhall/src/Dhall/Syntax/Instances/Pretty.hs-boot @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Dhall.Syntax.Instances.Pretty where + +import Dhall.Syntax.Types (Expr) +import Prettyprinter (Pretty) + +instance Pretty a => Pretty (Expr s a) diff --git a/dhall/src/Dhall/Syntax/Instances/Semigroup.hs b/dhall/src/Dhall/Syntax/Instances/Semigroup.hs new file mode 100644 index 000000000..96a96e917 --- /dev/null +++ b/dhall/src/Dhall/Syntax/Instances/Semigroup.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Dhall.Syntax.Instances.Semigroup () where + +import Dhall.Syntax.Instances.Functor () +import Dhall.Syntax.Types + +instance Semigroup (Chunks s a) where + Chunks xysL zL <> Chunks [] zR = + Chunks xysL (zL <> zR) + Chunks xysL zL <> Chunks ((x, y):xysR) zR = + Chunks (xysL ++ (zL <> x, y):xysR) zR + +instance Semigroup Directory where + Directory components0 <> Directory components1 = + Directory (components1 <> components0) + +instance Semigroup File where + File directory0 _ <> File directory1 file = + File (directory0 <> directory1) file + +instance Semigroup ImportType where + Local prefix file0 <> Local Here file1 = Local prefix (file0 <> file1) + + Remote (URL { path = path0, ..}) <> Local Here path1 = + Remote (URL { path = path0 <> path1, ..}) + + Local prefix file0 <> Local Parent file1 = + Local prefix (file0 <> parent <> file1) + + Remote (URL { path = path0, .. }) <> Local Parent path1 = + Remote (URL { path = path0 <> parent <> path1, .. }) + + import0 <> Remote (URL { headers = headers0, .. }) = + Remote (URL { headers = headers1, .. }) + where + importHashed0 = Import (ImportHashed Nothing import0) Code + + headers1 = fmap (fmap (importHashed0 <>)) headers0 + + _ <> import1 = + import1 + +instance Semigroup ImportHashed where + ImportHashed _ importType0 <> ImportHashed hash importType1 = + ImportHashed hash (importType0 <> importType1) + +instance Semigroup Import where + Import importHashed0 _ <> Import importHashed1 code = + Import (importHashed0 <> importHashed1) code + +parent :: File +parent = File { directory = Directory { components = [ ".." ] }, file = "" } diff --git a/dhall/src/Dhall/Syntax/Instances/Show.hs b/dhall/src/Dhall/Syntax/Instances/Show.hs new file mode 100644 index 000000000..005ba038c --- /dev/null +++ b/dhall/src/Dhall/Syntax/Instances/Show.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Dhall.Syntax.Instances.Show () where + +import Dhall.Syntax.Types + +deriving instance Show Const +deriving instance Show Var +deriving instance (Show s, Show a) => Show (Binding s a) +deriving instance Show DhallDouble +deriving instance (Show s, Show a) => Show (Chunks s a) +deriving instance (Show s, Show a) => Show (PreferAnnotation s a) +deriving instance (Show s, Show a) => Show (RecordField s a) +deriving instance (Show s, Show a) => Show (FunctionBinding s a) +deriving instance Show s => Show (FieldSelection s) +deriving instance Show WithComponent +deriving instance (Show s, Show a) => Show (Expr s a) +deriving instance Show Directory +deriving instance Show File +deriving instance Show FilePrefix +deriving instance Show Scheme +deriving instance Show URL +deriving instance Show ImportType +deriving instance Show ImportMode +deriving instance Show ImportHashed +deriving instance Show Import diff --git a/dhall/src/Dhall/Syntax/Instances/Traversable.hs b/dhall/src/Dhall/Syntax/Instances/Traversable.hs new file mode 100644 index 000000000..94beea11a --- /dev/null +++ b/dhall/src/Dhall/Syntax/Instances/Traversable.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Dhall.Syntax.Instances.Traversable () where + +import Dhall.Syntax.Instances.Foldable () +import Dhall.Syntax.Instances.Functor () +import Dhall.Syntax.Types + +deriving instance Traversable (Binding s) +deriving instance Traversable (Chunks s) +deriving instance Traversable (PreferAnnotation s) +deriving instance Traversable (RecordField s) +deriving instance Traversable (FunctionBinding s) +deriving instance Traversable FieldSelection +deriving instance Traversable (Expr s) diff --git a/dhall/src/Dhall/Syntax/Operations.hs b/dhall/src/Dhall/Syntax/Operations.hs new file mode 100644 index 000000000..97e7a5cad --- /dev/null +++ b/dhall/src/Dhall/Syntax/Operations.hs @@ -0,0 +1,543 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Dhall.Syntax.Operations ( + -- ** Optics + subExpressions + , subExpressionsWith + , unsafeSubExpressions + , chunkExprs + , bindingExprs + , recordFieldExprs + , functionBindingExprs + + -- ** Handling 'Note's + , denote + , renote + , shallowDenote + + -- * Reserved identifiers + , reservedIdentifiers + , reservedKeywords + + -- * `Data.Text.Text` manipulation + , toDoubleQuoted + , longestSharedWhitespacePrefix + , linesLiteral + , unlinesLiteral + + -- * Utilities + , internalError + -- `shift` should really be in `Dhall.Normalize`, but it's here to avoid a + -- module cycle + , shift + ) where + +import Data.HashSet (HashSet) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Src (Src (..)) +import Dhall.Syntax.Instances.Monoid () +import Dhall.Syntax.Types +import Unsafe.Coerce (unsafeCoerce) + +import qualified Data.Foldable +import qualified Data.HashSet +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Text +import qualified Lens.Family as Lens + + +-- | A traversal over the immediate sub-expressions of an expression. +subExpressions + :: Applicative f => (Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a) +subExpressions = subExpressionsWith (pure . Embed) +{-# INLINABLE subExpressions #-} + +{-| A traversal over the immediate sub-expressions of an expression which + allows mapping embedded values +-} +subExpressionsWith + :: Applicative f => (a -> f (Expr s b)) -> (Expr s a -> f (Expr s b)) -> Expr s a -> f (Expr s b) +subExpressionsWith h _ (Embed a) = h a +subExpressionsWith _ f (Note a b) = Note a <$> f b +subExpressionsWith _ f (Let a b) = Let <$> bindingExprs f a <*> f b +subExpressionsWith _ f (Record a) = Record <$> traverse (recordFieldExprs f) a +subExpressionsWith _ f (RecordLit a) = RecordLit <$> traverse (recordFieldExprs f) a +subExpressionsWith _ f (Lam cs fb e) = Lam cs <$> functionBindingExprs f fb <*> f e +subExpressionsWith _ f (Field a b) = Field <$> f a <*> pure b +subExpressionsWith _ f expression = unsafeSubExpressions f expression +{-# INLINABLE subExpressionsWith #-} + +{-| An internal utility used to implement transformations that require changing + one of the type variables of the `Expr` type + + This utility only works because the implementation is partial, not + handling the `Let`, `Note`, or `Embed` cases, which need to be handled by + the caller. +-} +unsafeSubExpressions + :: Applicative f => (Expr s a -> f (Expr t b)) -> Expr s a -> f (Expr t b) +unsafeSubExpressions _ (Const c) = pure (Const c) +unsafeSubExpressions _ (Var v) = pure (Var v) +unsafeSubExpressions f (Pi cs a b c) = Pi cs a <$> f b <*> f c +unsafeSubExpressions f (App a b) = App <$> f a <*> f b +unsafeSubExpressions f (Annot a b) = Annot <$> f a <*> f b +unsafeSubExpressions _ Bool = pure Bool +unsafeSubExpressions _ (BoolLit b) = pure (BoolLit b) +unsafeSubExpressions f (BoolAnd a b) = BoolAnd <$> f a <*> f b +unsafeSubExpressions f (BoolOr a b) = BoolOr <$> f a <*> f b +unsafeSubExpressions f (BoolEQ a b) = BoolEQ <$> f a <*> f b +unsafeSubExpressions f (BoolNE a b) = BoolNE <$> f a <*> f b +unsafeSubExpressions f (BoolIf a b c) = BoolIf <$> f a <*> f b <*> f c +unsafeSubExpressions _ Natural = pure Natural +unsafeSubExpressions _ (NaturalLit n) = pure (NaturalLit n) +unsafeSubExpressions _ NaturalFold = pure NaturalFold +unsafeSubExpressions _ NaturalBuild = pure NaturalBuild +unsafeSubExpressions _ NaturalIsZero = pure NaturalIsZero +unsafeSubExpressions _ NaturalEven = pure NaturalEven +unsafeSubExpressions _ NaturalOdd = pure NaturalOdd +unsafeSubExpressions _ NaturalToInteger = pure NaturalToInteger +unsafeSubExpressions _ NaturalShow = pure NaturalShow +unsafeSubExpressions _ NaturalSubtract = pure NaturalSubtract +unsafeSubExpressions f (NaturalPlus a b) = NaturalPlus <$> f a <*> f b +unsafeSubExpressions f (NaturalTimes a b) = NaturalTimes <$> f a <*> f b +unsafeSubExpressions _ Integer = pure Integer +unsafeSubExpressions _ (IntegerLit n) = pure (IntegerLit n) +unsafeSubExpressions _ IntegerClamp = pure IntegerClamp +unsafeSubExpressions _ IntegerNegate = pure IntegerNegate +unsafeSubExpressions _ IntegerShow = pure IntegerShow +unsafeSubExpressions _ IntegerToDouble = pure IntegerToDouble +unsafeSubExpressions _ Double = pure Double +unsafeSubExpressions _ (DoubleLit n) = pure (DoubleLit n) +unsafeSubExpressions _ DoubleShow = pure DoubleShow +unsafeSubExpressions _ Text = pure Text +unsafeSubExpressions f (TextLit chunks) = + TextLit <$> chunkExprs f chunks +unsafeSubExpressions f (TextAppend a b) = TextAppend <$> f a <*> f b +unsafeSubExpressions _ TextReplace = pure TextReplace +unsafeSubExpressions _ TextShow = pure TextShow +unsafeSubExpressions _ Date = pure Date +unsafeSubExpressions _ (DateLiteral a) = pure (DateLiteral a) +unsafeSubExpressions _ Time = pure Time +unsafeSubExpressions _ (TimeLiteral a b) = pure (TimeLiteral a b) +unsafeSubExpressions _ TimeZone = pure TimeZone +unsafeSubExpressions _ (TimeZoneLiteral a) = pure (TimeZoneLiteral a) +unsafeSubExpressions _ List = pure List +unsafeSubExpressions f (ListLit a b) = ListLit <$> traverse f a <*> traverse f b +unsafeSubExpressions f (ListAppend a b) = ListAppend <$> f a <*> f b +unsafeSubExpressions _ ListBuild = pure ListBuild +unsafeSubExpressions _ ListFold = pure ListFold +unsafeSubExpressions _ ListLength = pure ListLength +unsafeSubExpressions _ ListHead = pure ListHead +unsafeSubExpressions _ ListLast = pure ListLast +unsafeSubExpressions _ ListIndexed = pure ListIndexed +unsafeSubExpressions _ ListReverse = pure ListReverse +unsafeSubExpressions _ Optional = pure Optional +unsafeSubExpressions f (Some a) = Some <$> f a +unsafeSubExpressions _ None = pure None +unsafeSubExpressions f (Union a) = Union <$> traverse (traverse f) a +unsafeSubExpressions f (Combine cs a b c) = Combine cs a <$> f b <*> f c +unsafeSubExpressions f (CombineTypes cs a b) = CombineTypes cs <$> f a <*> f b +unsafeSubExpressions f (Prefer cs a b c) = Prefer cs <$> a' <*> f b <*> f c + where + a' = case a of + PreferFromSource -> pure PreferFromSource + PreferFromWith d -> PreferFromWith <$> f d + PreferFromCompletion -> pure PreferFromCompletion +unsafeSubExpressions f (RecordCompletion a b) = RecordCompletion <$> f a <*> f b +unsafeSubExpressions f (Merge a b t) = Merge <$> f a <*> f b <*> traverse f t +unsafeSubExpressions f (ToMap a t) = ToMap <$> f a <*> traverse f t +unsafeSubExpressions f (ShowConstructor a) = ShowConstructor <$> f a +unsafeSubExpressions f (Project a b) = Project <$> f a <*> traverse f b +unsafeSubExpressions f (Assert a) = Assert <$> f a +unsafeSubExpressions f (Equivalent cs a b) = Equivalent cs <$> f a <*> f b +unsafeSubExpressions f (With a b c) = With <$> f a <*> pure b <*> f c +unsafeSubExpressions f (ImportAlt l r) = ImportAlt <$> f l <*> f r +unsafeSubExpressions _ (Let {}) = unhandledConstructor "Let" +unsafeSubExpressions _ (Note {}) = unhandledConstructor "Note" +unsafeSubExpressions _ (Embed {}) = unhandledConstructor "Embed" +unsafeSubExpressions _ (Record {}) = unhandledConstructor "Record" +unsafeSubExpressions _ (RecordLit {}) = unhandledConstructor "RecordLit" +unsafeSubExpressions _ (Lam {}) = unhandledConstructor "Lam" +unsafeSubExpressions _ (Field {}) = unhandledConstructor "Field" +{-# INLINABLE unsafeSubExpressions #-} + +unhandledConstructor :: Text -> a +unhandledConstructor constructor = + internalError + ( "Dhall.Syntax.unsafeSubExpressions: Unhandled " + <> constructor + <> " construtor" + ) + +{-| Traverse over the immediate 'Expr' children in a 'Binding'. +-} +bindingExprs + :: (Applicative f) + => (Expr s a -> f (Expr s b)) + -> Binding s a -> f (Binding s b) +bindingExprs f (Binding s0 n s1 t s2 v) = + Binding + <$> pure s0 + <*> pure n + <*> pure s1 + <*> traverse (traverse f) t + <*> pure s2 + <*> f v +{-# INLINABLE bindingExprs #-} + +{-| Traverse over the immediate 'Expr' children in a 'RecordField'. +-} +recordFieldExprs + :: Applicative f + => (Expr s a -> f (Expr s b)) + -> RecordField s a -> f (RecordField s b) +recordFieldExprs f (RecordField s0 e s1 s2) = + RecordField + <$> pure s0 + <*> f e + <*> pure s1 + <*> pure s2 +{-# INLINABLE recordFieldExprs #-} + +{-| Traverse over the immediate 'Expr' children in a 'FunctionBinding'. +-} +functionBindingExprs + :: Applicative f + => (Expr s a -> f (Expr s b)) + -> FunctionBinding s a -> f (FunctionBinding s b) +functionBindingExprs f (FunctionBinding s0 label s1 s2 type_) = + FunctionBinding + <$> pure s0 + <*> pure label + <*> pure s1 + <*> pure s2 + <*> f type_ +{-# INLINABLE functionBindingExprs #-} + +-- | A traversal over the immediate sub-expressions in 'Chunks'. +chunkExprs + :: Applicative f + => (Expr s a -> f (Expr t b)) + -> Chunks s a -> f (Chunks t b) +chunkExprs f (Chunks chunks final) = + flip Chunks final <$> traverse (traverse f) chunks +{-# INLINABLE chunkExprs #-} + +-- | Remove all `Note` constructors from an `Expr` (i.e. de-`Note`) +-- +-- This also remove CharacterSet annotations. +denote :: Expr s a -> Expr t a +denote = \case + Note _ b -> denote b + Let a b -> Let (denoteBinding a) (denote b) + Embed a -> Embed a + Combine _ _ b c -> Combine Nothing Nothing (denote b) (denote c) + CombineTypes _ b c -> CombineTypes Nothing (denote b) (denote c) + Prefer _ a b c -> Lens.over unsafeSubExpressions denote $ Prefer Nothing a b c + Record a -> Record $ denoteRecordField <$> a + RecordLit a -> RecordLit $ denoteRecordField <$> a + Lam _ a b -> Lam Nothing (denoteFunctionBinding a) (denote b) + Pi _ t a b -> Pi Nothing t (denote a) (denote b) + Field a (FieldSelection _ b _) -> Field (denote a) (FieldSelection Nothing b Nothing) + Equivalent _ a b -> Equivalent Nothing (denote a) (denote b) + expression -> Lens.over unsafeSubExpressions denote expression + where + denoteRecordField (RecordField _ e _ _) = RecordField Nothing (denote e) Nothing Nothing + denoteBinding (Binding _ c _ d _ e) = + Binding Nothing c Nothing (fmap denoteBindingAnnotation d) Nothing (denote e) + + denoteBindingAnnotation (_, f) = (Nothing, denote f) + + denoteFunctionBinding (FunctionBinding _ l _ _ t) = + FunctionBinding Nothing l Nothing Nothing (denote t) + +-- | The \"opposite\" of `denote`, like @first absurd@ but faster +renote :: Expr Void a -> Expr s a +renote = unsafeCoerce +{-# INLINE renote #-} + +{-| Remove any outermost `Note` constructors + + This is typically used when you want to get the outermost non-`Note` + constructor without removing internal `Note` constructors +-} +shallowDenote :: Expr s a -> Expr s a +shallowDenote (Note _ e) = shallowDenote e +shallowDenote e = e + +-- | The set of reserved keywords according to the @keyword@ rule in the grammar +reservedKeywords :: HashSet Text +reservedKeywords = + Data.HashSet.fromList + [ "if" + , "then" + , "else" + , "let" + , "in" + , "using" + , "missing" + , "as" + , "Infinity" + , "NaN" + , "merge" + , "Some" + , "toMap" + , "assert" + , "forall" + , "with" + ] + +-- | The set of reserved identifiers for the Dhall language +-- | Contains also all keywords from "reservedKeywords" +reservedIdentifiers :: HashSet Text +reservedIdentifiers = reservedKeywords <> + Data.HashSet.fromList + [ -- Builtins according to the `builtin` rule in the grammar + "Natural/fold" + , "Natural/build" + , "Natural/isZero" + , "Natural/even" + , "Natural/odd" + , "Natural/toInteger" + , "Natural/show" + , "Natural/subtract" + , "Integer" + , "Integer/clamp" + , "Integer/negate" + , "Integer/show" + , "Integer/toDouble" + , "Integer/show" + , "Natural/subtract" + , "Double/show" + , "List/build" + , "List/fold" + , "List/length" + , "List/head" + , "List/last" + , "List/indexed" + , "List/reverse" + , "Text/replace" + , "Text/show" + , "Bool" + , "True" + , "False" + , "Optional" + , "None" + , "Natural" + , "Integer" + , "Double" + , "Text" + , "Date" + , "Time" + , "TimeZone" + , "List" + , "Type" + , "Kind" + , "Sort" + ] + +-- | Same as @Data.Text.splitOn@, except always returning a `NonEmpty` result +splitOn :: Text -> Text -> NonEmpty Text +splitOn needle haystack = + case Data.Text.splitOn needle haystack of + [] -> "" :| [] + t : ts -> t :| ts + +-- | Split `Chunks` by lines +linesLiteral :: Chunks s a -> NonEmpty (Chunks s a) +linesLiteral (Chunks [] suffix) = + fmap (Chunks []) (splitOn "\n" suffix) +linesLiteral (Chunks ((prefix, interpolation) : pairs₀) suffix₀) = + foldr + NonEmpty.cons + (Chunks ((lastLine, interpolation) : pairs₁) suffix₁ :| chunks) + (fmap (Chunks []) initLines) + where + splitLines = splitOn "\n" prefix + + initLines = NonEmpty.init splitLines + lastLine = NonEmpty.last splitLines + + Chunks pairs₁ suffix₁ :| chunks = linesLiteral (Chunks pairs₀ suffix₀) + +-- | Flatten several `Chunks` back into a single `Chunks` by inserting newlines +unlinesLiteral :: NonEmpty (Chunks s a) -> Chunks s a +unlinesLiteral chunks = + Data.Foldable.fold (NonEmpty.intersperse "\n" chunks) + +-- | Returns `True` if the `Chunks` represents a blank line +emptyLine :: Chunks s a -> Bool +emptyLine (Chunks [] "" ) = True +emptyLine (Chunks [] "\r") = True -- So that `\r\n` is treated as a blank line +emptyLine _ = False + +-- | Return the leading whitespace for a `Chunks` literal +leadingSpaces :: Chunks s a -> Text +leadingSpaces chunks = Data.Text.takeWhile isSpace firstText + where + isSpace c = c == ' ' || c == '\t' + + firstText = + case chunks of + Chunks [] suffix -> suffix + Chunks ((prefix, _) : _ ) _ -> prefix + +{-| Compute the longest shared whitespace prefix for the purposes of stripping + leading indentation +-} +longestSharedWhitespacePrefix :: NonEmpty (Chunks s a) -> Text +longestSharedWhitespacePrefix literals = + case fmap leadingSpaces filteredLines of + l : ls -> Data.Foldable.foldl' sharedPrefix l ls + [] -> "" + where + sharedPrefix ab ac = + case Data.Text.commonPrefixes ab ac of + Just (a, _b, _c) -> a + Nothing -> "" + + -- The standard specifies to filter out blank lines for all lines *except* + -- for the last line + filteredLines = newInit <> pure oldLast + where + oldInit = NonEmpty.init literals + + oldLast = NonEmpty.last literals + + newInit = filter (not . emptyLine) oldInit + +-- | Drop the first @n@ characters for a `Chunks` literal +dropLiteral :: Int -> Chunks s a -> Chunks s a +dropLiteral n (Chunks [] suffix) = + Chunks [] (Data.Text.drop n suffix) +dropLiteral n (Chunks ((prefix, interpolation) : rest) suffix) = + Chunks ((Data.Text.drop n prefix, interpolation) : rest) suffix + +{-| Convert a single-quoted `Chunks` literal to the equivalent double-quoted + `Chunks` literal +-} +toDoubleQuoted :: Chunks Src a -> Chunks Src a +toDoubleQuoted literal = + unlinesLiteral (fmap (dropLiteral indent) literals) + where + literals = linesLiteral literal + + longestSharedPrefix = longestSharedWhitespacePrefix literals + + indent = Data.Text.length longestSharedPrefix + +{-| `shift` is used by both normalization and type-checking to avoid variable + capture by shifting variable indices + + For example, suppose that you were to normalize the following expression: + +> λ(a : Type) → λ(x : a) → (λ(y : a) → λ(x : a) → y) x + + If you were to substitute @y@ with @x@ without shifting any variable + indices, then you would get the following incorrect result: + +> λ(a : Type) → λ(x : a) → λ(x : a) → x -- Incorrect normalized form + + In order to substitute @x@ in place of @y@ we need to `shift` @x@ by @1@ in + order to avoid being misinterpreted as the @x@ bound by the innermost + lambda. If we perform that `shift` then we get the correct result: + +> λ(a : Type) → λ(x : a) → λ(x : a) → x@1 + + As a more worked example, suppose that you were to normalize the following + expression: + +> λ(a : Type) +> → λ(f : a → a → a) +> → λ(x : a) +> → λ(x : a) +> → (λ(x : a) → f x x@1) x@1 + + The correct normalized result would be: + +> λ(a : Type) +> → λ(f : a → a → a) +> → λ(x : a) +> → λ(x : a) +> → f x@1 x + + The above example illustrates how we need to both increase and decrease + variable indices as part of substitution: + + * We need to increase the index of the outer @x\@1@ to @x\@2@ before we + substitute it into the body of the innermost lambda expression in order + to avoid variable capture. This substitution changes the body of the + lambda expression to @(f x\@2 x\@1)@ + + * We then remove the innermost lambda and therefore decrease the indices of + both @x@s in @(f x\@2 x\@1)@ to @(f x\@1 x)@ in order to reflect that one + less @x@ variable is now bound within that scope + + Formally, @(shift d (V x n) e)@ modifies the expression @e@ by adding @d@ to + the indices of all variables named @x@ whose indices are greater than + @(n + m)@, where @m@ is the number of bound variables of the same name + within that scope + + In practice, @d@ is always @1@ or @-1@ because we either: + + * increment variables by @1@ to avoid variable capture during substitution + * decrement variables by @1@ when deleting lambdas after substitution + + @n@ starts off at @0@ when substitution begins and increments every time we + descend into a lambda or let expression that binds a variable of the same + name in order to avoid shifting the bound variables by mistake. +-} +shift :: Int -> Var -> Expr s a -> Expr s a +shift d (V x n) (Var (V x' n')) = Var (V x' n'') + where + n'' = if x == x' && n <= n' then n' + d else n' +shift d (V x n) (Lam cs (FunctionBinding src0 x' src1 src2 _A) b) = + Lam cs (FunctionBinding src0 x' src1 src2 _A') b' + where + _A' = shift d (V x n ) _A + b' = shift d (V x n') b + where + n' = if x == x' then n + 1 else n +shift d (V x n) (Pi cs x' _A _B) = Pi cs x' _A' _B' + where + _A' = shift d (V x n ) _A + _B' = shift d (V x n') _B + where + n' = if x == x' then n + 1 else n +shift d (V x n) (Let (Binding src0 f src1 mt src2 r) e) = + Let (Binding src0 f src1 mt' src2 r') e' + where + e' = shift d (V x n') e + where + n' = if x == f then n + 1 else n + + mt' = fmap (fmap (shift d (V x n))) mt + r' = shift d (V x n) r +shift d v expression = Lens.over subExpressions (shift d v) expression + +_ERROR :: String +_ERROR = "\ESC[1;31mError\ESC[0m" + +{-| Utility function used to throw internal errors that should never happen + (in theory) but that are not enforced by the type system +-} +internalError :: Data.Text.Text -> forall b . b +internalError text = error (unlines + [ _ERROR <> ": Compiler bug " + , " " + , "Explanation: This error message means that there is a bug in the Dhall compiler." + , "You didn't do anything wrong, but if you would like to see this problem fixed " + , "then you should report the bug at: " + , " " + , "https://github.com/dhall-lang/dhall-haskell/issues " + , " " + , "Please include the following text in your bug report: " + , " " + , "``` " + , Data.Text.unpack text <> " " + , "``` " + ] ) diff --git a/dhall/src/Dhall/Syntax/Operations.hs-boot b/dhall/src/Dhall/Syntax/Operations.hs-boot new file mode 100644 index 000000000..550778f79 --- /dev/null +++ b/dhall/src/Dhall/Syntax/Operations.hs-boot @@ -0,0 +1,5 @@ +module Dhall.Syntax.Operations where + +import Dhall.Syntax.Types (Expr) + +unsafeSubExpressions :: Applicative f => (Expr s a -> f (Expr t b)) -> Expr s a -> f (Expr t b) diff --git a/dhall/src/Dhall/Syntax/Types.hs b/dhall/src/Dhall/Syntax/Types.hs new file mode 100644 index 000000000..c89a75dbd --- /dev/null +++ b/dhall/src/Dhall/Syntax/Types.hs @@ -0,0 +1,638 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} + +{-| This module contains the core syntax types. +-} + +module Dhall.Syntax.Types ( + -- * 'Expr' + Const(..) + , Var(..) + , Binding(..) + , makeBinding + , CharacterSet(..) + , Chunks(..) + , DhallDouble(..) + , PreferAnnotation(..) + , Expr(..) + , RecordField(..) + , makeRecordField + , FunctionBinding(..) + , makeFunctionBinding + , FieldSelection(..) + , makeFieldSelection + , WithComponent(..) + + -- ** 'Let'-blocks + , MultiLet(..) + , multiLet + , wrapInLets + + -- * 'Import' + , Directory(..) + , File(..) + , FilePrefix(..) + , Import(..) + , ImportHashed(..) + , ImportMode(..) + , ImportType(..) + , URL(..) + , Scheme(..) + ) where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Sequence (Seq) +import Data.String (IsString (..)) +import Data.Text (Text) +import Dhall.Map (Map) +import {-# SOURCE #-} Dhall.Pretty.Internal (CharacterSet (..)) +import Dhall.Src (Src (..)) +import GHC.Generics (Generic) +import Numeric.Natural (Natural) + +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Time as Time +import qualified Dhall.Crypto + +-- $setup +-- >>> import Dhall.Binary () -- For the orphan instance for `Serialise (Expr Void Import)` + +{-| Constants for a pure type system + + The axioms are: + +> ⊦ Type : Kind +> ⊦ Kind : Sort + + ... and the valid rule pairs are: + +> ⊦ Type ↝ Type : Type -- Functions from terms to terms (ordinary functions) +> ⊦ Kind ↝ Type : Type -- Functions from types to terms (type-polymorphic functions) +> ⊦ Sort ↝ Type : Type -- Functions from kinds to terms +> ⊦ Kind ↝ Kind : Kind -- Functions from types to types (type-level functions) +> ⊦ Sort ↝ Kind : Sort -- Functions from kinds to types (kind-polymorphic functions) +> ⊦ Sort ↝ Sort : Sort -- Functions from kinds to kinds (kind-level functions) + + Note that Dhall does not support functions from terms to types and therefore + Dhall is not a dependently typed language +-} +data Const = Type | Kind | Sort + deriving (Bounded, Enum, Generic) + +{-| Label for a bound variable + + The `Data.Text.Text` field is the variable's name (i.e. \"@x@\"). + + The `Int` field disambiguates variables with the same name if there are + multiple bound variables of the same name in scope. Zero refers to the + nearest bound variable and the index increases by one for each bound + variable of the same name going outward. The following diagram may help: + +> ┌──refers to──┐ +> │ │ +> v │ +> λ(x : Type) → λ(y : Type) → λ(x : Type) → x@0 +> +> ┌─────────────────refers to─────────────────┐ +> │ │ +> v │ +> λ(x : Type) → λ(y : Type) → λ(x : Type) → x@1 + + This `Int` behaves like a De Bruijn index in the special case where all + variables have the same name. + + You can optionally omit the index if it is @0@: + +> ┌─refers to─┐ +> │ │ +> v │ +> λ(x : Type) → λ(y : Type) → λ(x : Type) → x + + Zero indices are omitted when pretty-printing @Var@s and non-zero indices + appear as a numeric suffix. +-} +data Var = V Text !Int + deriving Generic + +instance IsString Var where + fromString str = V (fromString str) 0 + +-- | Record the binding part of a @let@ expression. +-- +-- For example, +-- +-- > let {- A -} x {- B -} : {- C -} Bool = {- D -} True in x +-- +-- … will be instantiated as follows: +-- +-- * @bindingSrc0@ corresponds to the @A@ comment. +-- * @variable@ is @"x"@ +-- * @bindingSrc1@ corresponds to the @B@ comment. +-- * @annotation@ is 'Just' a pair, corresponding to the @C@ comment and @Bool@. +-- * @bindingSrc2@ corresponds to the @D@ comment. +-- * @value@ corresponds to @True@. +data Binding s a = Binding + { bindingSrc0 :: Maybe s + , variable :: Text + , bindingSrc1 :: Maybe s + , annotation :: Maybe (Maybe s, Expr s a) + , bindingSrc2 :: Maybe s + , value :: Expr s a + } deriving Generic + +{-| Construct a 'Binding' with no source information and no type annotation. +-} +makeBinding :: Text -> Expr s a -> Binding s a +makeBinding name = Binding Nothing name Nothing Nothing Nothing + +-- | This wrapper around 'Prelude.Double' exists for its 'Eq' instance which is +-- defined via the binary encoding of Dhall @Double@s. +newtype DhallDouble = DhallDouble { getDhallDouble :: Double } + deriving Generic + +-- | The body of an interpolated @Text@ literal +data Chunks s a = Chunks [(Text, Expr s a)] Text + deriving Generic + +instance IsString (Chunks s a) where + fromString str = Chunks [] (fromString str) + +-- | Used to record the origin of a @//@ operator (i.e. from source code or a +-- product of desugaring) +data PreferAnnotation s a + = PreferFromSource + | PreferFromWith (Expr s a) + -- ^ Stores the original @with@ expression + | PreferFromCompletion + deriving Generic + +-- | Record the field of a record-type and record-literal expression. +-- The reason why we use the same ADT for both of them is because they store +-- the same information. +-- +-- For example, +-- +-- > { {- A -} x {- B -} : {- C -} T } +-- +-- ... or +-- +-- > { {- A -} x {- B -} = {- C -} T } +-- +-- will be instantiated as follows: +-- +-- * @recordFieldSrc0@ corresponds to the @A@ comment. +-- * @recordFieldValue@ is @"T"@ +-- * @recordFieldSrc1@ corresponds to the @B@ comment. +-- * @recordFieldSrc2@ corresponds to the @C@ comment. +-- +-- Although the @A@ comment isn't annotating the @"T"@ Record Field, +-- this is the best place to keep these comments. +-- +-- Note that @recordFieldSrc2@ is always 'Nothing' when the 'RecordField' is for +-- a punned entry, because there is no @=@ sign. For example, +-- +-- > { {- A -} x {- B -} } +-- +-- will be instantiated as follows: +-- +-- * @recordFieldSrc0@ corresponds to the @A@ comment. +-- * @recordFieldValue@ corresponds to @(Var "x")@ +-- * @recordFieldSrc1@ corresponds to the @B@ comment. +-- * @recordFieldSrc2@ will be 'Nothing' +-- +-- The labels involved in a record using dot-syntax like in this example: +-- +-- > { {- A -} a {- B -} . {- C -} b {- D -} . {- E -} c {- F -} = {- G -} e } +-- +-- will be instantiated as follows: +-- +-- * For both the @a@ and @b@ field, @recordfieldSrc2@ is 'Nothing' +-- * For the @a@ field: +-- * @recordFieldSrc0@ corresponds to the @A@ comment +-- * @recordFieldSrc1@ corresponds to the @B@ comment +-- * For the @b@ field: +-- * @recordFieldSrc0@ corresponds to the @C@ comment +-- * @recordFieldSrc1@ corresponds to the @D@ comment +-- * For the @c@ field: +-- * @recordFieldSrc0@ corresponds to the @E@ comment +-- * @recordFieldSrc1@ corresponds to the @F@ comment +-- * @recordFieldSrc2@ corresponds to the @G@ comment +-- +-- That is, for every label except the last one the semantics of +-- @recordFieldSrc0@ and @recordFieldSrc1@ are the same from a regular record +-- label but @recordFieldSrc2@ is always 'Nothing'. For the last keyword, all +-- srcs are 'Just' +data RecordField s a = RecordField + { recordFieldSrc0 :: Maybe s + , recordFieldValue :: Expr s a + , recordFieldSrc1 :: Maybe s + , recordFieldSrc2 :: Maybe s + } deriving Generic + +-- | Construct a 'RecordField' with no src information +makeRecordField :: Expr s a -> RecordField s a +makeRecordField e = RecordField Nothing e Nothing Nothing + +-- | Record the label of a function or a function-type expression +-- +-- For example, +-- +-- > λ({- A -} a {- B -} : {- C -} T) -> e +-- +-- … will be instantiated as follows: +-- +-- * @functionBindingSrc0@ corresponds to the @A@ comment +-- * @functionBindingVariable@ is @a@ +-- * @functionBindingSrc1@ corresponds to the @B@ comment +-- * @functionBindingSrc2@ corresponds to the @C@ comment +-- * @functionBindingAnnotation@ is @T@ +data FunctionBinding s a = FunctionBinding + { functionBindingSrc0 :: Maybe s + , functionBindingVariable :: Text + , functionBindingSrc1 :: Maybe s + , functionBindingSrc2 :: Maybe s + , functionBindingAnnotation :: Expr s a + } deriving Generic + +-- | Smart constructor for 'FunctionBinding' with no src information +makeFunctionBinding :: Text -> Expr s a -> FunctionBinding s a +makeFunctionBinding l t = FunctionBinding Nothing l Nothing Nothing t + +-- | Record the field on a selector-expression +-- +-- For example, +-- +-- > e . {- A -} x {- B -} +-- +-- … will be instantiated as follows: +-- +-- * @fieldSelectionSrc0@ corresponds to the @A@ comment +-- * @fieldSelectionLabel@ corresponds to @x@ +-- * @fieldSelectionSrc1@ corresponds to the @B@ comment +-- +-- Given our limitation that not all expressions recover their whitespaces, the +-- purpose of @fieldSelectionSrc1@ is to save the 'Text.Megaparsec.SourcePos' +-- where the @fieldSelectionLabel@ ends, but we /still/ use a 'Maybe Src' +-- (@s = 'Src'@) to be consistent with similar data types such as 'Binding', for +-- example. +data FieldSelection s = FieldSelection + { fieldSelectionSrc0 :: Maybe s + , fieldSelectionLabel :: !Text + , fieldSelectionSrc1 :: Maybe s + } deriving Generic + +-- | Smart constructor for 'FieldSelection' with no src information +makeFieldSelection :: Text -> FieldSelection s +makeFieldSelection t = FieldSelection Nothing t Nothing + +-- | A path component for a @with@ expression +data WithComponent = WithLabel Text | WithQuestion + deriving Generic + +{-| Syntax tree for expressions + + The @s@ type parameter is used to track the presence or absence of `Src` + spans: + + * If @s = `Src`@ then the code may contains `Src` spans (either in a `Note` + constructor or inline within another constructor, like `Let`) + * If @s = `Void`@ then the code has no `Src` spans + + The @a@ type parameter is used to track the presence or absence of imports + + * If @a = `Import`@ then the code may contain unresolved `Import`s + * If @a = `Void`@ then the code has no `Import`s +-} +data Expr s a + -- | > Const c ~ c + = Const Const + -- | > Var (V x 0) ~ x + -- > Var (V x n) ~ x@n + | Var Var + -- | > Lam _ (FunctionBinding _ "x" _ _ A) b ~ λ(x : A) -> b + | Lam (Maybe CharacterSet) (FunctionBinding s a) (Expr s a) + -- | > Pi _ "_" A B ~ A -> B + -- > Pi _ x A B ~ ∀(x : A) -> B + | Pi (Maybe CharacterSet) Text (Expr s a) (Expr s a) + -- | > App f a ~ f a + | App (Expr s a) (Expr s a) + -- | > Let (Binding _ x _ Nothing _ r) e ~ let x = r in e + -- > Let (Binding _ x _ (Just t ) _ r) e ~ let x : t = r in e + -- + -- The difference between + -- + -- > let x = a let y = b in e + -- + -- and + -- + -- > let x = a in let y = b in e + -- + -- is only an additional 'Note' around @'Let' "y" …@ in the second + -- example. + -- + -- See 'MultiLet' for a representation of let-blocks that mirrors the + -- source code more closely. + | Let (Binding s a) (Expr s a) + -- | > Annot x t ~ x : t + | Annot (Expr s a) (Expr s a) + -- | > Bool ~ Bool + | Bool + -- | > BoolLit b ~ b + | BoolLit Bool + -- | > BoolAnd x y ~ x && y + | BoolAnd (Expr s a) (Expr s a) + -- | > BoolOr x y ~ x || y + | BoolOr (Expr s a) (Expr s a) + -- | > BoolEQ x y ~ x == y + | BoolEQ (Expr s a) (Expr s a) + -- | > BoolNE x y ~ x != y + | BoolNE (Expr s a) (Expr s a) + -- | > BoolIf x y z ~ if x then y else z + | BoolIf (Expr s a) (Expr s a) (Expr s a) + -- | > Natural ~ Natural + | Natural + -- | > NaturalLit n ~ n + | NaturalLit Natural + -- | > NaturalFold ~ Natural/fold + | NaturalFold + -- | > NaturalBuild ~ Natural/build + | NaturalBuild + -- | > NaturalIsZero ~ Natural/isZero + | NaturalIsZero + -- | > NaturalEven ~ Natural/even + | NaturalEven + -- | > NaturalOdd ~ Natural/odd + | NaturalOdd + -- | > NaturalToInteger ~ Natural/toInteger + | NaturalToInteger + -- | > NaturalShow ~ Natural/show + | NaturalShow + -- | > NaturalSubtract ~ Natural/subtract + | NaturalSubtract + -- | > NaturalPlus x y ~ x + y + | NaturalPlus (Expr s a) (Expr s a) + -- | > NaturalTimes x y ~ x * y + | NaturalTimes (Expr s a) (Expr s a) + -- | > Integer ~ Integer + | Integer + -- | > IntegerLit n ~ ±n + | IntegerLit Integer + -- | > IntegerClamp ~ Integer/clamp + | IntegerClamp + -- | > IntegerNegate ~ Integer/negate + | IntegerNegate + -- | > IntegerShow ~ Integer/show + | IntegerShow + -- | > IntegerToDouble ~ Integer/toDouble + | IntegerToDouble + -- | > Double ~ Double + | Double + -- | > DoubleLit n ~ n + | DoubleLit DhallDouble + -- | > DoubleShow ~ Double/show + | DoubleShow + -- | > Text ~ Text + | Text + -- | > TextLit (Chunks [(t1, e1), (t2, e2)] t3) ~ "t1${e1}t2${e2}t3" + | TextLit (Chunks s a) + -- | > TextAppend x y ~ x ++ y + | TextAppend (Expr s a) (Expr s a) + -- | > TextReplace ~ Text/replace + | TextReplace + -- | > TextShow ~ Text/show + | TextShow + -- | > Date ~ Date + | Date + -- | > DateLiteral (fromGregorian _YYYY _MM _DD) ~ YYYY-MM-DD + | DateLiteral Time.Day + -- | > Time ~ Time + | Time + -- | > TimeLiteral (TimeOfDay hh mm ss) _ ~ hh:mm:ss + | TimeLiteral + Time.TimeOfDay + Word + -- ^ Precision + -- | > TimeZone ~ TimeZone + | TimeZone + -- | > TimeZoneLiteral (TimeZone ( 60 * _HH + _MM) _ _) ~ +HH:MM + -- | > TimeZoneLiteral (TimeZone (-60 * _HH + _MM) _ _) ~ -HH:MM + | TimeZoneLiteral Time.TimeZone + -- | > List ~ List + | List + -- | > ListLit (Just t ) [] ~ [] : t + -- > ListLit Nothing [x, y, z] ~ [x, y, z] + -- + -- Invariant: A non-empty list literal is always represented as + -- @ListLit Nothing xs@. + -- + -- When an annotated, non-empty list literal is parsed, it is represented + -- as + -- + -- > Annot (ListLit Nothing [x, y, z]) t ~ [x, y, z] : t + + -- Eventually we should have separate constructors for empty and non-empty + -- list literals. For now it's easier to check the invariant in @infer@. + -- See https://github.com/dhall-lang/dhall-haskell/issues/1359#issuecomment-537087234. + | ListLit (Maybe (Expr s a)) (Seq (Expr s a)) + -- | > ListAppend x y ~ x # y + | ListAppend (Expr s a) (Expr s a) + -- | > ListBuild ~ List/build + | ListBuild + -- | > ListFold ~ List/fold + | ListFold + -- | > ListLength ~ List/length + | ListLength + -- | > ListHead ~ List/head + | ListHead + -- | > ListLast ~ List/last + | ListLast + -- | > ListIndexed ~ List/indexed + | ListIndexed + -- | > ListReverse ~ List/reverse + | ListReverse + -- | > Optional ~ Optional + | Optional + -- | > Some e ~ Some e + | Some (Expr s a) + -- | > None ~ None + | None + -- | > Record [ (k1, RecordField _ t1) ~ { k1 : t1, k2 : t1 } + -- > , (k2, RecordField _ t2) + -- > ] + | Record (Map Text (RecordField s a)) + -- | > RecordLit [ (k1, RecordField _ v1) ~ { k1 = v1, k2 = v2 } + -- > , (k2, RecordField _ v2) + -- > ] + | RecordLit (Map Text (RecordField s a)) + -- | > Union [(k1, Just t1), (k2, Nothing)] ~ < k1 : t1 | k2 > + | Union (Map Text (Maybe (Expr s a))) + -- | > Combine _ Nothing x y ~ x ∧ y + -- + -- The first field is a `Just` when the `Combine` operator is introduced + -- as a result of desugaring duplicate record fields: + -- + -- > RecordLit [ ( k ~ { k = x, k = y } + -- > , RecordField + -- > _ + -- > (Combine (Just k) x y) + -- > )] + | Combine (Maybe CharacterSet) (Maybe Text) (Expr s a) (Expr s a) + -- | > CombineTypes _ x y ~ x ⩓ y + | CombineTypes (Maybe CharacterSet) (Expr s a) (Expr s a) + -- | > Prefer _ False x y ~ x ⫽ y + -- + -- The first field is a `True` when the `Prefer` operator is introduced as a + -- result of desugaring a @with@ expression + | Prefer (Maybe CharacterSet) (PreferAnnotation s a) (Expr s a) (Expr s a) + -- | > RecordCompletion x y ~ x::y + | RecordCompletion (Expr s a) (Expr s a) + -- | > Merge x y (Just t ) ~ merge x y : t + -- > Merge x y Nothing ~ merge x y + | Merge (Expr s a) (Expr s a) (Maybe (Expr s a)) + -- | > ToMap x (Just t) ~ toMap x : t + -- > ToMap x Nothing ~ toMap x + | ToMap (Expr s a) (Maybe (Expr s a)) + -- | > ShowConstructor x ~ showConstructor x + | ShowConstructor (Expr s a) + -- | > Field e (FieldSelection _ x _) ~ e.x + | Field (Expr s a) (FieldSelection s) + -- | > Project e (Left xs) ~ e.{ xs } + -- > Project e (Right t) ~ e.(t) + | Project (Expr s a) (Either [Text] (Expr s a)) + -- | > Assert e ~ assert : e + | Assert (Expr s a) + -- | > Equivalent _ x y ~ x ≡ y + | Equivalent (Maybe CharacterSet) (Expr s a) (Expr s a) + -- | > With x y e ~ x with y = e + | With (Expr s a) (NonEmpty WithComponent) (Expr s a) + -- | > Note s x ~ e + | Note s (Expr s a) + -- | > ImportAlt ~ e1 ? e2 + | ImportAlt (Expr s a) (Expr s a) + -- | > Embed import ~ import + | Embed a + deriving Generic +-- NB: If you add a constructor to Expr, please also update the Arbitrary +-- instance in Dhall.Test.QuickCheck. + +instance IsString (Expr s a) where + fromString str = Var (fromString str) + +{- +Instead of converting explicitly between 'Expr's and 'MultiLet', it might +be nicer to use a pattern synonym: + +> pattern MultiLet' :: NonEmpty (Binding s a) -> Expr s a -> Expr s a +> pattern MultiLet' as b <- (multiLetFromExpr -> Just (MultiLet as b)) where +> MultiLet' as b = wrapInLets as b +> +> multiLetFromExpr :: Expr s a -> Maybe (MultiLet s a) +> multiLetFromExpr = \case +> Let x mA a b -> Just (multiLet x mA a b) +> _ -> Nothing + +This works in principle, but GHC as of v8.8.1 doesn't handle it well: +https://gitlab.haskell.org/ghc/ghc/issues/17096 + +This should be fixed by GHC-8.10, so it might be worth revisiting then. +-} + +{-| Generate a 'MultiLet' from the contents of a 'Let'. + + In the resulting @'MultiLet' bs e@, @e@ is guaranteed not to be a 'Let', + but it might be a @('Note' … ('Let' …))@. + + Given parser output, 'multiLet' consolidates @let@s that formed a + let-block in the original source. +-} +multiLet :: Binding s a -> Expr s a -> MultiLet s a +multiLet b0 = \case + Let b1 e1 -> + let MultiLet bs e = multiLet b1 e1 + in MultiLet (NonEmpty.cons b0 bs) e + e -> MultiLet (b0 :| []) e + +{-| Wrap let-'Binding's around an 'Expr'. + +'wrapInLets' can be understood as an inverse for 'multiLet': + +> let MultiLet bs e1 = multiLet b e0 +> +> wrapInLets bs e1 == Let b e0 +-} +wrapInLets :: Foldable f => f (Binding s a) -> Expr s a -> Expr s a +wrapInLets bs e = foldr Let e bs + +{-| This type represents 1 or more nested `Let` bindings that have been + coalesced together for ease of manipulation +-} +data MultiLet s a = MultiLet (NonEmpty (Binding s a)) (Expr s a) + +{-| Internal representation of a directory that stores the path components in + reverse order + + In other words, the directory @\/foo\/bar\/baz@ is encoded as + @Directory { components = [ "baz", "bar", "foo" ] }@ +-} +newtype Directory = Directory { components :: [Text] } + deriving Generic + +{-| A `File` is a `directory` followed by one additional path component + representing the `file` name +-} +data File = File + { directory :: Directory + , file :: Text + } deriving Generic + +-- | The beginning of a file path which anchors subsequent path components +data FilePrefix + = Absolute + -- ^ Absolute path + | Here + -- ^ Path relative to @.@ + | Parent + -- ^ Path relative to @..@ + | Home + -- ^ Path relative to @~@ + deriving Generic + +-- | The URI scheme +data Scheme = HTTP | HTTPS + deriving Generic + +-- | This type stores all of the components of a remote import +data URL = URL + { scheme :: Scheme + , authority :: Text + , path :: File + , query :: Maybe Text + , headers :: Maybe (Expr Src Import) + } deriving Generic + +-- | The type of import (i.e. local vs. remote vs. environment) +data ImportType + = Local FilePrefix File + -- ^ Local path + | Remote URL + -- ^ URL of remote resource and optional headers stored in an import + | Env Text + -- ^ Environment variable + | Missing + deriving Generic + +-- | How to interpret the import's contents (i.e. as Dhall code or raw text) +data ImportMode = Code | RawText | Location + deriving Generic + +-- | A `ImportType` extended with an optional hash for semantic integrity checks +data ImportHashed = ImportHashed + { hash :: Maybe Dhall.Crypto.SHA256Digest + , importType :: ImportType + } deriving Generic + +-- | Reference to an external resource +data Import = Import + { importHashed :: ImportHashed + , importMode :: ImportMode + } deriving Generic diff --git a/dhall/src/Dhall/Syntax/Types.hs-boot b/dhall/src/Dhall/Syntax/Types.hs-boot new file mode 100644 index 000000000..7f79bd367 --- /dev/null +++ b/dhall/src/Dhall/Syntax/Types.hs-boot @@ -0,0 +1,7 @@ +module Dhall.Syntax.Types where + +data Var + +data Const + +data Expr s a From fd4650f328292fafdcbfad54e95e70240a552e7f Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Sat, 27 Aug 2022 00:39:00 +0200 Subject: [PATCH 02/13] Moved some types to own modules - Expr lives in Dhall.Syntax.Expr - Import and friends live in Dhall.Syntax.Import - Const lives in Dhall.Syntax.Const - Var lives in Dhall.Syntax.Var --- dhall/dhall.cabal | 4 + dhall/src/Dhall/Pretty/Internal.hs-boot | 4 +- dhall/src/Dhall/Syntax.hs | 4 + dhall/src/Dhall/Syntax.hs-boot | 7 - dhall/src/Dhall/Syntax/Const.hs | 29 ++ dhall/src/Dhall/Syntax/Expr.hs | 255 ++++++++++++ dhall/src/Dhall/Syntax/Expr.hs-boot | 3 + dhall/src/Dhall/Syntax/Import.hs | 92 +++++ .../src/Dhall/Syntax/Instances/Applicative.hs | 1 + dhall/src/Dhall/Syntax/Instances/Bifunctor.hs | 1 + dhall/src/Dhall/Syntax/Instances/Data.hs | 3 + dhall/src/Dhall/Syntax/Instances/Eq.hs | 6 +- dhall/src/Dhall/Syntax/Instances/Foldable.hs | 1 + dhall/src/Dhall/Syntax/Instances/Functor.hs | 1 + dhall/src/Dhall/Syntax/Instances/Lift.hs | 3 + dhall/src/Dhall/Syntax/Instances/Monad.hs | 2 +- dhall/src/Dhall/Syntax/Instances/NFData.hs | 6 +- dhall/src/Dhall/Syntax/Instances/Ord.hs | 4 + dhall/src/Dhall/Syntax/Instances/Pretty.hs | 5 +- .../src/Dhall/Syntax/Instances/Pretty.hs-boot | 4 +- dhall/src/Dhall/Syntax/Instances/Semigroup.hs | 1 + dhall/src/Dhall/Syntax/Instances/Show.hs | 4 + .../src/Dhall/Syntax/Instances/Traversable.hs | 1 + dhall/src/Dhall/Syntax/Operations.hs | 2 + dhall/src/Dhall/Syntax/Operations.hs-boot | 2 +- dhall/src/Dhall/Syntax/Types.hs | 381 +----------------- dhall/src/Dhall/Syntax/Types.hs-boot | 16 +- dhall/src/Dhall/Syntax/Var.hs | 47 +++ 28 files changed, 492 insertions(+), 397 deletions(-) delete mode 100644 dhall/src/Dhall/Syntax.hs-boot create mode 100644 dhall/src/Dhall/Syntax/Const.hs create mode 100644 dhall/src/Dhall/Syntax/Expr.hs create mode 100644 dhall/src/Dhall/Syntax/Expr.hs-boot create mode 100644 dhall/src/Dhall/Syntax/Import.hs create mode 100644 dhall/src/Dhall/Syntax/Var.hs diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index df03c332e..fa1ef859d 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -360,6 +360,9 @@ Library Dhall.Parser.Combinators Dhall.Pretty.Internal Dhall.Syntax + Dhall.Syntax.Const + Dhall.Syntax.Expr + Dhall.Syntax.Import Dhall.Syntax.Instances.Applicative Dhall.Syntax.Instances.Bifunctor Dhall.Syntax.Instances.Data @@ -377,6 +380,7 @@ Library Dhall.Syntax.Instances.Traversable Dhall.Syntax.Operations Dhall.Syntax.Types + Dhall.Syntax.Var Dhall.URL Paths_dhall Autogen-Modules: diff --git a/dhall/src/Dhall/Pretty/Internal.hs-boot b/dhall/src/Dhall/Pretty/Internal.hs-boot index 0ccec6cd3..3daabb732 100644 --- a/dhall/src/Dhall/Pretty/Internal.hs-boot +++ b/dhall/src/Dhall/Pretty/Internal.hs-boot @@ -7,7 +7,9 @@ import Prettyprinter (Pretty, Doc) import Dhall.Src (Src) import Language.Haskell.TH.Syntax (Lift) -import {-# SOURCE #-} Dhall.Syntax.Types +import {-# SOURCE #-} Dhall.Syntax.Expr +import Dhall.Syntax.Const +import Dhall.Syntax.Var data Ann diff --git a/dhall/src/Dhall/Syntax.hs b/dhall/src/Dhall/Syntax.hs index deb67fa50..0a0a293ec 100644 --- a/dhall/src/Dhall/Syntax.hs +++ b/dhall/src/Dhall/Syntax.hs @@ -2,6 +2,9 @@ module Dhall.Syntax ( module Export ) where +import Dhall.Syntax.Const as Export +import Dhall.Syntax.Expr as Export +import Dhall.Syntax.Import as Export import Dhall.Syntax.Instances.Applicative as Export () import Dhall.Syntax.Instances.Bifunctor as Export () import Dhall.Syntax.Instances.Data as Export () @@ -19,3 +22,4 @@ import Dhall.Syntax.Instances.Show as Export () import Dhall.Syntax.Instances.Traversable as Export () import Dhall.Syntax.Operations as Export import Dhall.Syntax.Types as Export +import Dhall.Syntax.Var as Export diff --git a/dhall/src/Dhall/Syntax.hs-boot b/dhall/src/Dhall/Syntax.hs-boot deleted file mode 100644 index 01aa0dcbb..000000000 --- a/dhall/src/Dhall/Syntax.hs-boot +++ /dev/null @@ -1,7 +0,0 @@ -module Dhall.Syntax where - -data Var - -data Const - -data Expr s a diff --git a/dhall/src/Dhall/Syntax/Const.hs b/dhall/src/Dhall/Syntax/Const.hs new file mode 100644 index 000000000..922034ad7 --- /dev/null +++ b/dhall/src/Dhall/Syntax/Const.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Dhall.Syntax.Const ( + Const(..) + ) where + +import GHC.Generics (Generic) + +{-| Constants for a pure type system + + The axioms are: + +> ⊦ Type : Kind +> ⊦ Kind : Sort + + ... and the valid rule pairs are: + +> ⊦ Type ↝ Type : Type -- Functions from terms to terms (ordinary functions) +> ⊦ Kind ↝ Type : Type -- Functions from types to terms (type-polymorphic functions) +> ⊦ Sort ↝ Type : Type -- Functions from kinds to terms +> ⊦ Kind ↝ Kind : Kind -- Functions from types to types (type-level functions) +> ⊦ Sort ↝ Kind : Sort -- Functions from kinds to types (kind-polymorphic functions) +> ⊦ Sort ↝ Sort : Sort -- Functions from kinds to kinds (kind-level functions) + + Note that Dhall does not support functions from terms to types and therefore + Dhall is not a dependently typed language +-} +data Const = Type | Kind | Sort + deriving (Bounded, Enum, Generic) diff --git a/dhall/src/Dhall/Syntax/Expr.hs b/dhall/src/Dhall/Syntax/Expr.hs new file mode 100644 index 000000000..62c544b4d --- /dev/null +++ b/dhall/src/Dhall/Syntax/Expr.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE DeriveGeneric #-} + +{-| This module contains the core syntax types and optics for them. + +'reservedIdentifiers', 'denote' and friends are included because they are +involved in a dependency circle with "Dhall.Pretty.Internal". +-} + +module Dhall.Syntax.Expr + ( Expr(..) + ) where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Sequence (Seq) +import Data.String (IsString (..)) +import Data.Text (Text) +import Data.Traversable () +import Dhall.Map (Map) +import {-# SOURCE #-} Dhall.Pretty.Internal (CharacterSet (..)) +import Dhall.Syntax.Const +import {-# SOURCE #-} Dhall.Syntax.Types +import Dhall.Syntax.Var +import GHC.Generics (Generic) +import Numeric.Natural (Natural) + +import qualified Data.Time as Time + +{-| Syntax tree for expressions + + The @s@ type parameter is used to track the presence or absence of `Src` + spans: + + * If @s = `Src`@ then the code may contains `Src` spans (either in a `Note` + constructor or inline within another constructor, like `Let`) + * If @s = `Void`@ then the code has no `Src` spans + + The @a@ type parameter is used to track the presence or absence of imports + + * If @a = `Import`@ then the code may contain unresolved `Import`s + * If @a = `Void`@ then the code has no `Import`s +-} +data Expr s a + -- | > Const c ~ c + = Const Const + -- | > Var (V x 0) ~ x + -- > Var (V x n) ~ x@n + | Var Var + -- | > Lam _ (FunctionBinding _ "x" _ _ A) b ~ λ(x : A) -> b + | Lam (Maybe CharacterSet) (FunctionBinding s a) (Expr s a) + -- | > Pi _ "_" A B ~ A -> B + -- > Pi _ x A B ~ ∀(x : A) -> B + | Pi (Maybe CharacterSet) Text (Expr s a) (Expr s a) + -- | > App f a ~ f a + | App (Expr s a) (Expr s a) + -- | > Let (Binding _ x _ Nothing _ r) e ~ let x = r in e + -- > Let (Binding _ x _ (Just t ) _ r) e ~ let x : t = r in e + -- + -- The difference between + -- + -- > let x = a let y = b in e + -- + -- and + -- + -- > let x = a in let y = b in e + -- + -- is only an additional 'Note' around @'Let' "y" …@ in the second + -- example. + -- + -- See 'MultiLet' for a representation of let-blocks that mirrors the + -- source code more closely. + | Let (Binding s a) (Expr s a) + -- | > Annot x t ~ x : t + | Annot (Expr s a) (Expr s a) + -- | > Bool ~ Bool + | Bool + -- | > BoolLit b ~ b + | BoolLit Bool + -- | > BoolAnd x y ~ x && y + | BoolAnd (Expr s a) (Expr s a) + -- | > BoolOr x y ~ x || y + | BoolOr (Expr s a) (Expr s a) + -- | > BoolEQ x y ~ x == y + | BoolEQ (Expr s a) (Expr s a) + -- | > BoolNE x y ~ x != y + | BoolNE (Expr s a) (Expr s a) + -- | > BoolIf x y z ~ if x then y else z + | BoolIf (Expr s a) (Expr s a) (Expr s a) + -- | > Natural ~ Natural + | Natural + -- | > NaturalLit n ~ n + | NaturalLit Natural + -- | > NaturalFold ~ Natural/fold + | NaturalFold + -- | > NaturalBuild ~ Natural/build + | NaturalBuild + -- | > NaturalIsZero ~ Natural/isZero + | NaturalIsZero + -- | > NaturalEven ~ Natural/even + | NaturalEven + -- | > NaturalOdd ~ Natural/odd + | NaturalOdd + -- | > NaturalToInteger ~ Natural/toInteger + | NaturalToInteger + -- | > NaturalShow ~ Natural/show + | NaturalShow + -- | > NaturalSubtract ~ Natural/subtract + | NaturalSubtract + -- | > NaturalPlus x y ~ x + y + | NaturalPlus (Expr s a) (Expr s a) + -- | > NaturalTimes x y ~ x * y + | NaturalTimes (Expr s a) (Expr s a) + -- | > Integer ~ Integer + | Integer + -- | > IntegerLit n ~ ±n + | IntegerLit Integer + -- | > IntegerClamp ~ Integer/clamp + | IntegerClamp + -- | > IntegerNegate ~ Integer/negate + | IntegerNegate + -- | > IntegerShow ~ Integer/show + | IntegerShow + -- | > IntegerToDouble ~ Integer/toDouble + | IntegerToDouble + -- | > Double ~ Double + | Double + -- | > DoubleLit n ~ n + | DoubleLit DhallDouble + -- | > DoubleShow ~ Double/show + | DoubleShow + -- | > Text ~ Text + | Text + -- | > TextLit (Chunks [(t1, e1), (t2, e2)] t3) ~ "t1${e1}t2${e2}t3" + | TextLit (Chunks s a) + -- | > TextAppend x y ~ x ++ y + | TextAppend (Expr s a) (Expr s a) + -- | > TextReplace ~ Text/replace + | TextReplace + -- | > TextShow ~ Text/show + | TextShow + -- | > Date ~ Date + | Date + -- | > DateLiteral (fromGregorian _YYYY _MM _DD) ~ YYYY-MM-DD + | DateLiteral Time.Day + -- | > Time ~ Time + | Time + -- | > TimeLiteral (TimeOfDay hh mm ss) _ ~ hh:mm:ss + | TimeLiteral + Time.TimeOfDay + Word + -- ^ Precision + -- | > TimeZone ~ TimeZone + | TimeZone + -- | > TimeZoneLiteral (TimeZone ( 60 * _HH + _MM) _ _) ~ +HH:MM + -- | > TimeZoneLiteral (TimeZone (-60 * _HH + _MM) _ _) ~ -HH:MM + | TimeZoneLiteral Time.TimeZone + -- | > List ~ List + | List + -- | > ListLit (Just t ) [] ~ [] : t + -- > ListLit Nothing [x, y, z] ~ [x, y, z] + -- + -- Invariant: A non-empty list literal is always represented as + -- @ListLit Nothing xs@. + -- + -- When an annotated, non-empty list literal is parsed, it is represented + -- as + -- + -- > Annot (ListLit Nothing [x, y, z]) t ~ [x, y, z] : t + + -- Eventually we should have separate constructors for empty and non-empty + -- list literals. For now it's easier to check the invariant in @infer@. + -- See https://github.com/dhall-lang/dhall-haskell/issues/1359#issuecomment-537087234. + | ListLit (Maybe (Expr s a)) (Seq (Expr s a)) + -- | > ListAppend x y ~ x # y + | ListAppend (Expr s a) (Expr s a) + -- | > ListBuild ~ List/build + | ListBuild + -- | > ListFold ~ List/fold + | ListFold + -- | > ListLength ~ List/length + | ListLength + -- | > ListHead ~ List/head + | ListHead + -- | > ListLast ~ List/last + | ListLast + -- | > ListIndexed ~ List/indexed + | ListIndexed + -- | > ListReverse ~ List/reverse + | ListReverse + -- | > Optional ~ Optional + | Optional + -- | > Some e ~ Some e + | Some (Expr s a) + -- | > None ~ None + | None + -- | > Record [ (k1, RecordField _ t1) ~ { k1 : t1, k2 : t1 } + -- > , (k2, RecordField _ t2) + -- > ] + | Record (Map Text (RecordField s a)) + -- | > RecordLit [ (k1, RecordField _ v1) ~ { k1 = v1, k2 = v2 } + -- > , (k2, RecordField _ v2) + -- > ] + | RecordLit (Map Text (RecordField s a)) + -- | > Union [(k1, Just t1), (k2, Nothing)] ~ < k1 : t1 | k2 > + | Union (Map Text (Maybe (Expr s a))) + -- | > Combine _ Nothing x y ~ x ∧ y + -- + -- The first field is a `Just` when the `Combine` operator is introduced + -- as a result of desugaring duplicate record fields: + -- + -- > RecordLit [ ( k ~ { k = x, k = y } + -- > , RecordField + -- > _ + -- > (Combine (Just k) x y) + -- > )] + | Combine (Maybe CharacterSet) (Maybe Text) (Expr s a) (Expr s a) + -- | > CombineTypes _ x y ~ x ⩓ y + | CombineTypes (Maybe CharacterSet) (Expr s a) (Expr s a) + -- | > Prefer _ False x y ~ x ⫽ y + -- + -- The first field is a `True` when the `Prefer` operator is introduced as a + -- result of desugaring a @with@ expression + | Prefer (Maybe CharacterSet) (PreferAnnotation s a) (Expr s a) (Expr s a) + -- | > RecordCompletion x y ~ x::y + | RecordCompletion (Expr s a) (Expr s a) + -- | > Merge x y (Just t ) ~ merge x y : t + -- > Merge x y Nothing ~ merge x y + | Merge (Expr s a) (Expr s a) (Maybe (Expr s a)) + -- | > ToMap x (Just t) ~ toMap x : t + -- > ToMap x Nothing ~ toMap x + | ToMap (Expr s a) (Maybe (Expr s a)) + -- | > ShowConstructor x ~ showConstructor x + | ShowConstructor (Expr s a) + -- | > Field e (FieldSelection _ x _) ~ e.x + | Field (Expr s a) (FieldSelection s) + -- | > Project e (Left xs) ~ e.{ xs } + -- > Project e (Right t) ~ e.(t) + | Project (Expr s a) (Either [Text] (Expr s a)) + -- | > Assert e ~ assert : e + | Assert (Expr s a) + -- | > Equivalent _ x y ~ x ≡ y + | Equivalent (Maybe CharacterSet) (Expr s a) (Expr s a) + -- | > With x y e ~ x with y = e + | With (Expr s a) (NonEmpty WithComponent) (Expr s a) + -- | > Note s x ~ e + | Note s (Expr s a) + -- | > ImportAlt ~ e1 ? e2 + | ImportAlt (Expr s a) (Expr s a) + -- | > Embed import ~ import + | Embed a + deriving Generic +-- NB: If you add a constructor to Expr, please also update the Arbitrary +-- instance in Dhall.Test.QuickCheck. + +instance IsString (Expr s a) where + fromString str = Var (fromString str) diff --git a/dhall/src/Dhall/Syntax/Expr.hs-boot b/dhall/src/Dhall/Syntax/Expr.hs-boot new file mode 100644 index 000000000..c83bb7a6a --- /dev/null +++ b/dhall/src/Dhall/Syntax/Expr.hs-boot @@ -0,0 +1,3 @@ +module Dhall.Syntax.Expr where + +data Expr s a diff --git a/dhall/src/Dhall/Syntax/Import.hs b/dhall/src/Dhall/Syntax/Import.hs new file mode 100644 index 000000000..843c5d82d --- /dev/null +++ b/dhall/src/Dhall/Syntax/Import.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DeriveGeneric #-} + +{-| This module contains the core syntax types. +-} + +module Dhall.Syntax.Import ( + Directory(..) + , File(..) + , FilePrefix(..) + , Import(..) + , ImportHashed(..) + , ImportMode(..) + , ImportType(..) + , URL(..) + , Scheme(..) + ) where + +import Data.Text (Text) +import Dhall.Src (Src (..)) +import Dhall.Syntax.Expr (Expr (..)) +import GHC.Generics (Generic) + +import qualified Dhall.Crypto + +{-| Internal representation of a directory that stores the path components in + reverse order + + In other words, the directory @\/foo\/bar\/baz@ is encoded as + @Directory { components = [ "baz", "bar", "foo" ] }@ +-} +newtype Directory = Directory { components :: [Text] } + deriving Generic + +{-| A `File` is a `directory` followed by one additional path component + representing the `file` name +-} +data File = File + { directory :: Directory + , file :: Text + } deriving Generic + +-- | The beginning of a file path which anchors subsequent path components +data FilePrefix + = Absolute + -- ^ Absolute path + | Here + -- ^ Path relative to @.@ + | Parent + -- ^ Path relative to @..@ + | Home + -- ^ Path relative to @~@ + deriving Generic + +-- | The URI scheme +data Scheme = HTTP | HTTPS + deriving Generic + +-- | This type stores all of the components of a remote import +data URL = URL + { scheme :: Scheme + , authority :: Text + , path :: File + , query :: Maybe Text + , headers :: Maybe (Expr Src Import) + } deriving Generic + +-- | The type of import (i.e. local vs. remote vs. environment) +data ImportType + = Local FilePrefix File + -- ^ Local path + | Remote URL + -- ^ URL of remote resource and optional headers stored in an import + | Env Text + -- ^ Environment variable + | Missing + deriving Generic + +-- | How to interpret the import's contents (i.e. as Dhall code or raw text) +data ImportMode = Code | RawText | Location + deriving Generic + +-- | A `ImportType` extended with an optional hash for semantic integrity checks +data ImportHashed = ImportHashed + { hash :: Maybe Dhall.Crypto.SHA256Digest + , importType :: ImportType + } deriving Generic + +-- | Reference to an external resource +data Import = Import + { importHashed :: ImportHashed + , importMode :: ImportMode + } deriving Generic diff --git a/dhall/src/Dhall/Syntax/Instances/Applicative.hs b/dhall/src/Dhall/Syntax/Instances/Applicative.hs index 9c6392e13..07d5dccfc 100644 --- a/dhall/src/Dhall/Syntax/Instances/Applicative.hs +++ b/dhall/src/Dhall/Syntax/Instances/Applicative.hs @@ -2,6 +2,7 @@ module Dhall.Syntax.Instances.Applicative () where +import Dhall.Syntax.Expr import Dhall.Syntax.Operations import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs b/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs index 97a688e56..d1211371c 100644 --- a/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs +++ b/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs @@ -3,6 +3,7 @@ module Dhall.Syntax.Instances.Bifunctor () where import Data.Bifunctor (Bifunctor (..)) +import Dhall.Syntax.Expr import Dhall.Syntax.Operations import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Data.hs b/dhall/src/Dhall/Syntax/Instances/Data.hs index d9e1788f0..53648fe68 100644 --- a/dhall/src/Dhall/Syntax/Instances/Data.hs +++ b/dhall/src/Dhall/Syntax/Instances/Data.hs @@ -6,7 +6,10 @@ module Dhall.Syntax.Instances.Data () where import Data.Data (Data) +import Dhall.Syntax.Const +import Dhall.Syntax.Expr import Dhall.Syntax.Types +import Dhall.Syntax.Var deriving instance Data Const deriving instance Data Var diff --git a/dhall/src/Dhall/Syntax/Instances/Eq.hs b/dhall/src/Dhall/Syntax/Instances/Eq.hs index c4c376b18..207955b6f 100644 --- a/dhall/src/Dhall/Syntax/Instances/Eq.hs +++ b/dhall/src/Dhall/Syntax/Instances/Eq.hs @@ -4,8 +4,12 @@ module Dhall.Syntax.Instances.Eq () where -import Data.Bits (xor) +import Data.Bits (xor) +import Dhall.Syntax.Const +import Dhall.Syntax.Expr +import Dhall.Syntax.Import import Dhall.Syntax.Types +import Dhall.Syntax.Var deriving instance Eq Const deriving instance Eq Var diff --git a/dhall/src/Dhall/Syntax/Instances/Foldable.hs b/dhall/src/Dhall/Syntax/Instances/Foldable.hs index 4827ef2ed..f4b815238 100644 --- a/dhall/src/Dhall/Syntax/Instances/Foldable.hs +++ b/dhall/src/Dhall/Syntax/Instances/Foldable.hs @@ -5,6 +5,7 @@ module Dhall.Syntax.Instances.Foldable () where +import Dhall.Syntax.Expr import Dhall.Syntax.Types deriving instance Foldable (Binding s) diff --git a/dhall/src/Dhall/Syntax/Instances/Functor.hs b/dhall/src/Dhall/Syntax/Instances/Functor.hs index a5c00e4de..35a12425f 100644 --- a/dhall/src/Dhall/Syntax/Instances/Functor.hs +++ b/dhall/src/Dhall/Syntax/Instances/Functor.hs @@ -5,6 +5,7 @@ module Dhall.Syntax.Instances.Functor () where +import Dhall.Syntax.Expr import {-# SOURCE #-} Dhall.Syntax.Operations (unsafeSubExpressions) import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Lift.hs b/dhall/src/Dhall/Syntax/Instances/Lift.hs index 9d35d1038..db22ca809 100644 --- a/dhall/src/Dhall/Syntax/Instances/Lift.hs +++ b/dhall/src/Dhall/Syntax/Instances/Lift.hs @@ -5,7 +5,10 @@ module Dhall.Syntax.Instances.Lift () where +import Dhall.Syntax.Const +import Dhall.Syntax.Expr import Dhall.Syntax.Types +import Dhall.Syntax.Var import Language.Haskell.TH.Syntax (Lift) import qualified Data.Fixed as Fixed diff --git a/dhall/src/Dhall/Syntax/Instances/Monad.hs b/dhall/src/Dhall/Syntax/Instances/Monad.hs index bf486c82d..9a6c28003 100644 --- a/dhall/src/Dhall/Syntax/Instances/Monad.hs +++ b/dhall/src/Dhall/Syntax/Instances/Monad.hs @@ -2,8 +2,8 @@ module Dhall.Syntax.Instances.Monad () where +import Dhall.Syntax.Expr import Dhall.Syntax.Instances.Applicative () -import Dhall.Syntax.Types import qualified Control.Monad diff --git a/dhall/src/Dhall/Syntax/Instances/NFData.hs b/dhall/src/Dhall/Syntax/Instances/NFData.hs index f7a413263..3fb03cd66 100644 --- a/dhall/src/Dhall/Syntax/Instances/NFData.hs +++ b/dhall/src/Dhall/Syntax/Instances/NFData.hs @@ -2,8 +2,12 @@ module Dhall.Syntax.Instances.NFData () where -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData) +import Dhall.Syntax.Const +import Dhall.Syntax.Expr +import Dhall.Syntax.Import import Dhall.Syntax.Types +import Dhall.Syntax.Var instance NFData Const instance NFData Var diff --git a/dhall/src/Dhall/Syntax/Instances/Ord.hs b/dhall/src/Dhall/Syntax/Instances/Ord.hs index 4daccd29e..6d747ee8f 100644 --- a/dhall/src/Dhall/Syntax/Instances/Ord.hs +++ b/dhall/src/Dhall/Syntax/Instances/Ord.hs @@ -4,8 +4,12 @@ module Dhall.Syntax.Instances.Ord () where +import Dhall.Syntax.Const +import Dhall.Syntax.Expr +import Dhall.Syntax.Import import Dhall.Syntax.Instances.Eq () import Dhall.Syntax.Types +import Dhall.Syntax.Var deriving instance Ord Const deriving instance Ord Var diff --git a/dhall/src/Dhall/Syntax/Instances/Pretty.hs b/dhall/src/Dhall/Syntax/Instances/Pretty.hs index e8e19e18e..fabed0b5d 100644 --- a/dhall/src/Dhall/Syntax/Instances/Pretty.hs +++ b/dhall/src/Dhall/Syntax/Instances/Pretty.hs @@ -9,7 +9,10 @@ module Dhall.Syntax.Instances.Pretty import Data.Text (Text) import {-# SOURCE #-} Dhall.Pretty.Internal -import Dhall.Syntax.Types +import Dhall.Syntax.Const +import Dhall.Syntax.Expr +import Dhall.Syntax.Import +import Dhall.Syntax.Var import Prettyprinter (Doc, Pretty) import qualified Data.Text diff --git a/dhall/src/Dhall/Syntax/Instances/Pretty.hs-boot b/dhall/src/Dhall/Syntax/Instances/Pretty.hs-boot index 8c68dc993..7cf9748ba 100644 --- a/dhall/src/Dhall/Syntax/Instances/Pretty.hs-boot +++ b/dhall/src/Dhall/Syntax/Instances/Pretty.hs-boot @@ -2,7 +2,7 @@ module Dhall.Syntax.Instances.Pretty where -import Dhall.Syntax.Types (Expr) -import Prettyprinter (Pretty) +import Dhall.Syntax.Expr (Expr) +import Prettyprinter (Pretty) instance Pretty a => Pretty (Expr s a) diff --git a/dhall/src/Dhall/Syntax/Instances/Semigroup.hs b/dhall/src/Dhall/Syntax/Instances/Semigroup.hs index 96a96e917..df64bf985 100644 --- a/dhall/src/Dhall/Syntax/Instances/Semigroup.hs +++ b/dhall/src/Dhall/Syntax/Instances/Semigroup.hs @@ -5,6 +5,7 @@ module Dhall.Syntax.Instances.Semigroup () where +import Dhall.Syntax.Import import Dhall.Syntax.Instances.Functor () import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Show.hs b/dhall/src/Dhall/Syntax/Instances/Show.hs index 005ba038c..9b4570184 100644 --- a/dhall/src/Dhall/Syntax/Instances/Show.hs +++ b/dhall/src/Dhall/Syntax/Instances/Show.hs @@ -4,7 +4,11 @@ module Dhall.Syntax.Instances.Show () where +import Dhall.Syntax.Const +import Dhall.Syntax.Expr +import Dhall.Syntax.Import import Dhall.Syntax.Types +import Dhall.Syntax.Var deriving instance Show Const deriving instance Show Var diff --git a/dhall/src/Dhall/Syntax/Instances/Traversable.hs b/dhall/src/Dhall/Syntax/Instances/Traversable.hs index 94beea11a..6d483de6a 100644 --- a/dhall/src/Dhall/Syntax/Instances/Traversable.hs +++ b/dhall/src/Dhall/Syntax/Instances/Traversable.hs @@ -5,6 +5,7 @@ module Dhall.Syntax.Instances.Traversable () where +import Dhall.Syntax.Expr import Dhall.Syntax.Instances.Foldable () import Dhall.Syntax.Instances.Functor () import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Operations.hs b/dhall/src/Dhall/Syntax/Operations.hs index 97e7a5cad..fda61ac54 100644 --- a/dhall/src/Dhall/Syntax/Operations.hs +++ b/dhall/src/Dhall/Syntax/Operations.hs @@ -39,8 +39,10 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) import Data.Void (Void) import Dhall.Src (Src (..)) +import Dhall.Syntax.Expr import Dhall.Syntax.Instances.Monoid () import Dhall.Syntax.Types +import Dhall.Syntax.Var import Unsafe.Coerce (unsafeCoerce) import qualified Data.Foldable diff --git a/dhall/src/Dhall/Syntax/Operations.hs-boot b/dhall/src/Dhall/Syntax/Operations.hs-boot index 550778f79..2dfc90793 100644 --- a/dhall/src/Dhall/Syntax/Operations.hs-boot +++ b/dhall/src/Dhall/Syntax/Operations.hs-boot @@ -1,5 +1,5 @@ module Dhall.Syntax.Operations where -import Dhall.Syntax.Types (Expr) +import Dhall.Syntax.Expr (Expr) unsafeSubExpressions :: Applicative f => (Expr s a -> f (Expr t b)) -> Expr s a -> f (Expr t b) diff --git a/dhall/src/Dhall/Syntax/Types.hs b/dhall/src/Dhall/Syntax/Types.hs index c89a75dbd..5f5d4d823 100644 --- a/dhall/src/Dhall/Syntax/Types.hs +++ b/dhall/src/Dhall/Syntax/Types.hs @@ -6,15 +6,12 @@ module Dhall.Syntax.Types ( -- * 'Expr' - Const(..) - , Var(..) - , Binding(..) + Binding(..) , makeBinding , CharacterSet(..) , Chunks(..) , DhallDouble(..) , PreferAnnotation(..) - , Expr(..) , RecordField(..) , makeRecordField , FunctionBinding(..) @@ -27,96 +24,20 @@ module Dhall.Syntax.Types ( , MultiLet(..) , multiLet , wrapInLets - - -- * 'Import' - , Directory(..) - , File(..) - , FilePrefix(..) - , Import(..) - , ImportHashed(..) - , ImportMode(..) - , ImportType(..) - , URL(..) - , Scheme(..) ) where import Data.List.NonEmpty (NonEmpty (..)) -import Data.Sequence (Seq) import Data.String (IsString (..)) import Data.Text (Text) -import Dhall.Map (Map) import {-# SOURCE #-} Dhall.Pretty.Internal (CharacterSet (..)) -import Dhall.Src (Src (..)) +import Dhall.Syntax.Expr (Expr (..)) import GHC.Generics (Generic) -import Numeric.Natural (Natural) import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Time as Time -import qualified Dhall.Crypto -- $setup -- >>> import Dhall.Binary () -- For the orphan instance for `Serialise (Expr Void Import)` -{-| Constants for a pure type system - - The axioms are: - -> ⊦ Type : Kind -> ⊦ Kind : Sort - - ... and the valid rule pairs are: - -> ⊦ Type ↝ Type : Type -- Functions from terms to terms (ordinary functions) -> ⊦ Kind ↝ Type : Type -- Functions from types to terms (type-polymorphic functions) -> ⊦ Sort ↝ Type : Type -- Functions from kinds to terms -> ⊦ Kind ↝ Kind : Kind -- Functions from types to types (type-level functions) -> ⊦ Sort ↝ Kind : Sort -- Functions from kinds to types (kind-polymorphic functions) -> ⊦ Sort ↝ Sort : Sort -- Functions from kinds to kinds (kind-level functions) - - Note that Dhall does not support functions from terms to types and therefore - Dhall is not a dependently typed language --} -data Const = Type | Kind | Sort - deriving (Bounded, Enum, Generic) - -{-| Label for a bound variable - - The `Data.Text.Text` field is the variable's name (i.e. \"@x@\"). - - The `Int` field disambiguates variables with the same name if there are - multiple bound variables of the same name in scope. Zero refers to the - nearest bound variable and the index increases by one for each bound - variable of the same name going outward. The following diagram may help: - -> ┌──refers to──┐ -> │ │ -> v │ -> λ(x : Type) → λ(y : Type) → λ(x : Type) → x@0 -> -> ┌─────────────────refers to─────────────────┐ -> │ │ -> v │ -> λ(x : Type) → λ(y : Type) → λ(x : Type) → x@1 - - This `Int` behaves like a De Bruijn index in the special case where all - variables have the same name. - - You can optionally omit the index if it is @0@: - -> ┌─refers to─┐ -> │ │ -> v │ -> λ(x : Type) → λ(y : Type) → λ(x : Type) → x - - Zero indices are omitted when pretty-printing @Var@s and non-zero indices - appear as a numeric suffix. --} -data Var = V Text !Int - deriving Generic - -instance IsString Var where - fromString str = V (fromString str) 0 - -- | Record the binding part of a @let@ expression. -- -- For example, @@ -289,235 +210,6 @@ makeFieldSelection t = FieldSelection Nothing t Nothing data WithComponent = WithLabel Text | WithQuestion deriving Generic -{-| Syntax tree for expressions - - The @s@ type parameter is used to track the presence or absence of `Src` - spans: - - * If @s = `Src`@ then the code may contains `Src` spans (either in a `Note` - constructor or inline within another constructor, like `Let`) - * If @s = `Void`@ then the code has no `Src` spans - - The @a@ type parameter is used to track the presence or absence of imports - - * If @a = `Import`@ then the code may contain unresolved `Import`s - * If @a = `Void`@ then the code has no `Import`s --} -data Expr s a - -- | > Const c ~ c - = Const Const - -- | > Var (V x 0) ~ x - -- > Var (V x n) ~ x@n - | Var Var - -- | > Lam _ (FunctionBinding _ "x" _ _ A) b ~ λ(x : A) -> b - | Lam (Maybe CharacterSet) (FunctionBinding s a) (Expr s a) - -- | > Pi _ "_" A B ~ A -> B - -- > Pi _ x A B ~ ∀(x : A) -> B - | Pi (Maybe CharacterSet) Text (Expr s a) (Expr s a) - -- | > App f a ~ f a - | App (Expr s a) (Expr s a) - -- | > Let (Binding _ x _ Nothing _ r) e ~ let x = r in e - -- > Let (Binding _ x _ (Just t ) _ r) e ~ let x : t = r in e - -- - -- The difference between - -- - -- > let x = a let y = b in e - -- - -- and - -- - -- > let x = a in let y = b in e - -- - -- is only an additional 'Note' around @'Let' "y" …@ in the second - -- example. - -- - -- See 'MultiLet' for a representation of let-blocks that mirrors the - -- source code more closely. - | Let (Binding s a) (Expr s a) - -- | > Annot x t ~ x : t - | Annot (Expr s a) (Expr s a) - -- | > Bool ~ Bool - | Bool - -- | > BoolLit b ~ b - | BoolLit Bool - -- | > BoolAnd x y ~ x && y - | BoolAnd (Expr s a) (Expr s a) - -- | > BoolOr x y ~ x || y - | BoolOr (Expr s a) (Expr s a) - -- | > BoolEQ x y ~ x == y - | BoolEQ (Expr s a) (Expr s a) - -- | > BoolNE x y ~ x != y - | BoolNE (Expr s a) (Expr s a) - -- | > BoolIf x y z ~ if x then y else z - | BoolIf (Expr s a) (Expr s a) (Expr s a) - -- | > Natural ~ Natural - | Natural - -- | > NaturalLit n ~ n - | NaturalLit Natural - -- | > NaturalFold ~ Natural/fold - | NaturalFold - -- | > NaturalBuild ~ Natural/build - | NaturalBuild - -- | > NaturalIsZero ~ Natural/isZero - | NaturalIsZero - -- | > NaturalEven ~ Natural/even - | NaturalEven - -- | > NaturalOdd ~ Natural/odd - | NaturalOdd - -- | > NaturalToInteger ~ Natural/toInteger - | NaturalToInteger - -- | > NaturalShow ~ Natural/show - | NaturalShow - -- | > NaturalSubtract ~ Natural/subtract - | NaturalSubtract - -- | > NaturalPlus x y ~ x + y - | NaturalPlus (Expr s a) (Expr s a) - -- | > NaturalTimes x y ~ x * y - | NaturalTimes (Expr s a) (Expr s a) - -- | > Integer ~ Integer - | Integer - -- | > IntegerLit n ~ ±n - | IntegerLit Integer - -- | > IntegerClamp ~ Integer/clamp - | IntegerClamp - -- | > IntegerNegate ~ Integer/negate - | IntegerNegate - -- | > IntegerShow ~ Integer/show - | IntegerShow - -- | > IntegerToDouble ~ Integer/toDouble - | IntegerToDouble - -- | > Double ~ Double - | Double - -- | > DoubleLit n ~ n - | DoubleLit DhallDouble - -- | > DoubleShow ~ Double/show - | DoubleShow - -- | > Text ~ Text - | Text - -- | > TextLit (Chunks [(t1, e1), (t2, e2)] t3) ~ "t1${e1}t2${e2}t3" - | TextLit (Chunks s a) - -- | > TextAppend x y ~ x ++ y - | TextAppend (Expr s a) (Expr s a) - -- | > TextReplace ~ Text/replace - | TextReplace - -- | > TextShow ~ Text/show - | TextShow - -- | > Date ~ Date - | Date - -- | > DateLiteral (fromGregorian _YYYY _MM _DD) ~ YYYY-MM-DD - | DateLiteral Time.Day - -- | > Time ~ Time - | Time - -- | > TimeLiteral (TimeOfDay hh mm ss) _ ~ hh:mm:ss - | TimeLiteral - Time.TimeOfDay - Word - -- ^ Precision - -- | > TimeZone ~ TimeZone - | TimeZone - -- | > TimeZoneLiteral (TimeZone ( 60 * _HH + _MM) _ _) ~ +HH:MM - -- | > TimeZoneLiteral (TimeZone (-60 * _HH + _MM) _ _) ~ -HH:MM - | TimeZoneLiteral Time.TimeZone - -- | > List ~ List - | List - -- | > ListLit (Just t ) [] ~ [] : t - -- > ListLit Nothing [x, y, z] ~ [x, y, z] - -- - -- Invariant: A non-empty list literal is always represented as - -- @ListLit Nothing xs@. - -- - -- When an annotated, non-empty list literal is parsed, it is represented - -- as - -- - -- > Annot (ListLit Nothing [x, y, z]) t ~ [x, y, z] : t - - -- Eventually we should have separate constructors for empty and non-empty - -- list literals. For now it's easier to check the invariant in @infer@. - -- See https://github.com/dhall-lang/dhall-haskell/issues/1359#issuecomment-537087234. - | ListLit (Maybe (Expr s a)) (Seq (Expr s a)) - -- | > ListAppend x y ~ x # y - | ListAppend (Expr s a) (Expr s a) - -- | > ListBuild ~ List/build - | ListBuild - -- | > ListFold ~ List/fold - | ListFold - -- | > ListLength ~ List/length - | ListLength - -- | > ListHead ~ List/head - | ListHead - -- | > ListLast ~ List/last - | ListLast - -- | > ListIndexed ~ List/indexed - | ListIndexed - -- | > ListReverse ~ List/reverse - | ListReverse - -- | > Optional ~ Optional - | Optional - -- | > Some e ~ Some e - | Some (Expr s a) - -- | > None ~ None - | None - -- | > Record [ (k1, RecordField _ t1) ~ { k1 : t1, k2 : t1 } - -- > , (k2, RecordField _ t2) - -- > ] - | Record (Map Text (RecordField s a)) - -- | > RecordLit [ (k1, RecordField _ v1) ~ { k1 = v1, k2 = v2 } - -- > , (k2, RecordField _ v2) - -- > ] - | RecordLit (Map Text (RecordField s a)) - -- | > Union [(k1, Just t1), (k2, Nothing)] ~ < k1 : t1 | k2 > - | Union (Map Text (Maybe (Expr s a))) - -- | > Combine _ Nothing x y ~ x ∧ y - -- - -- The first field is a `Just` when the `Combine` operator is introduced - -- as a result of desugaring duplicate record fields: - -- - -- > RecordLit [ ( k ~ { k = x, k = y } - -- > , RecordField - -- > _ - -- > (Combine (Just k) x y) - -- > )] - | Combine (Maybe CharacterSet) (Maybe Text) (Expr s a) (Expr s a) - -- | > CombineTypes _ x y ~ x ⩓ y - | CombineTypes (Maybe CharacterSet) (Expr s a) (Expr s a) - -- | > Prefer _ False x y ~ x ⫽ y - -- - -- The first field is a `True` when the `Prefer` operator is introduced as a - -- result of desugaring a @with@ expression - | Prefer (Maybe CharacterSet) (PreferAnnotation s a) (Expr s a) (Expr s a) - -- | > RecordCompletion x y ~ x::y - | RecordCompletion (Expr s a) (Expr s a) - -- | > Merge x y (Just t ) ~ merge x y : t - -- > Merge x y Nothing ~ merge x y - | Merge (Expr s a) (Expr s a) (Maybe (Expr s a)) - -- | > ToMap x (Just t) ~ toMap x : t - -- > ToMap x Nothing ~ toMap x - | ToMap (Expr s a) (Maybe (Expr s a)) - -- | > ShowConstructor x ~ showConstructor x - | ShowConstructor (Expr s a) - -- | > Field e (FieldSelection _ x _) ~ e.x - | Field (Expr s a) (FieldSelection s) - -- | > Project e (Left xs) ~ e.{ xs } - -- > Project e (Right t) ~ e.(t) - | Project (Expr s a) (Either [Text] (Expr s a)) - -- | > Assert e ~ assert : e - | Assert (Expr s a) - -- | > Equivalent _ x y ~ x ≡ y - | Equivalent (Maybe CharacterSet) (Expr s a) (Expr s a) - -- | > With x y e ~ x with y = e - | With (Expr s a) (NonEmpty WithComponent) (Expr s a) - -- | > Note s x ~ e - | Note s (Expr s a) - -- | > ImportAlt ~ e1 ? e2 - | ImportAlt (Expr s a) (Expr s a) - -- | > Embed import ~ import - | Embed a - deriving Generic --- NB: If you add a constructor to Expr, please also update the Arbitrary --- instance in Dhall.Test.QuickCheck. - -instance IsString (Expr s a) where - fromString str = Var (fromString str) - {- Instead of converting explicitly between 'Expr's and 'MultiLet', it might be nicer to use a pattern synonym: @@ -567,72 +259,3 @@ wrapInLets bs e = foldr Let e bs coalesced together for ease of manipulation -} data MultiLet s a = MultiLet (NonEmpty (Binding s a)) (Expr s a) - -{-| Internal representation of a directory that stores the path components in - reverse order - - In other words, the directory @\/foo\/bar\/baz@ is encoded as - @Directory { components = [ "baz", "bar", "foo" ] }@ --} -newtype Directory = Directory { components :: [Text] } - deriving Generic - -{-| A `File` is a `directory` followed by one additional path component - representing the `file` name --} -data File = File - { directory :: Directory - , file :: Text - } deriving Generic - --- | The beginning of a file path which anchors subsequent path components -data FilePrefix - = Absolute - -- ^ Absolute path - | Here - -- ^ Path relative to @.@ - | Parent - -- ^ Path relative to @..@ - | Home - -- ^ Path relative to @~@ - deriving Generic - --- | The URI scheme -data Scheme = HTTP | HTTPS - deriving Generic - --- | This type stores all of the components of a remote import -data URL = URL - { scheme :: Scheme - , authority :: Text - , path :: File - , query :: Maybe Text - , headers :: Maybe (Expr Src Import) - } deriving Generic - --- | The type of import (i.e. local vs. remote vs. environment) -data ImportType - = Local FilePrefix File - -- ^ Local path - | Remote URL - -- ^ URL of remote resource and optional headers stored in an import - | Env Text - -- ^ Environment variable - | Missing - deriving Generic - --- | How to interpret the import's contents (i.e. as Dhall code or raw text) -data ImportMode = Code | RawText | Location - deriving Generic - --- | A `ImportType` extended with an optional hash for semantic integrity checks -data ImportHashed = ImportHashed - { hash :: Maybe Dhall.Crypto.SHA256Digest - , importType :: ImportType - } deriving Generic - --- | Reference to an external resource -data Import = Import - { importHashed :: ImportHashed - , importMode :: ImportMode - } deriving Generic diff --git a/dhall/src/Dhall/Syntax/Types.hs-boot b/dhall/src/Dhall/Syntax/Types.hs-boot index 7f79bd367..992f02ed7 100644 --- a/dhall/src/Dhall/Syntax/Types.hs-boot +++ b/dhall/src/Dhall/Syntax/Types.hs-boot @@ -1,7 +1,17 @@ module Dhall.Syntax.Types where -data Var +data Binding s a -data Const +data DhallDouble -data Expr s a +data Chunks s a + +data PreferAnnotation s a + +data RecordField s a + +data FunctionBinding s a + +data FieldSelection s + +data WithComponent diff --git a/dhall/src/Dhall/Syntax/Var.hs b/dhall/src/Dhall/Syntax/Var.hs new file mode 100644 index 000000000..291032a25 --- /dev/null +++ b/dhall/src/Dhall/Syntax/Var.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Dhall.Syntax.Var ( + Var(..) + ) where + +import Data.String (IsString (..)) +import Data.Text (Text) +import GHC.Generics (Generic) + +{-| Label for a bound variable + + The `Data.Text.Text` field is the variable's name (i.e. \"@x@\"). + + The `Int` field disambiguates variables with the same name if there are + multiple bound variables of the same name in scope. Zero refers to the + nearest bound variable and the index increases by one for each bound + variable of the same name going outward. The following diagram may help: + +> ┌──refers to──┐ +> │ │ +> v │ +> λ(x : Type) → λ(y : Type) → λ(x : Type) → x@0 +> +> ┌─────────────────refers to─────────────────┐ +> │ │ +> v │ +> λ(x : Type) → λ(y : Type) → λ(x : Type) → x@1 + + This `Int` behaves like a De Bruijn index in the special case where all + variables have the same name. + + You can optionally omit the index if it is @0@: + +> ┌─refers to─┐ +> │ │ +> v │ +> λ(x : Type) → λ(y : Type) → λ(x : Type) → x + + Zero indices are omitted when pretty-printing @Var@s and non-zero indices + appear as a numeric suffix. +-} +data Var = V Text !Int + deriving Generic + +instance IsString Var where + fromString str = V (fromString str) 0 From 882865f870e97299b9f850c5d5935fa57fefb2c8 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 15 Sep 2022 11:48:19 +0200 Subject: [PATCH 03/13] Moved MultiLet to Dhall.Syntax.MultiLet --- dhall/dhall.cabal | 1 + dhall/src/Dhall/Syntax.hs | 1 + dhall/src/Dhall/Syntax/MultiLet.hs | 62 ++++++++++++++++++++++++++++++ dhall/src/Dhall/Syntax/Types.hs | 59 ---------------------------- 4 files changed, 64 insertions(+), 59 deletions(-) create mode 100644 dhall/src/Dhall/Syntax/MultiLet.hs diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index fa1ef859d..d7a822f67 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -378,6 +378,7 @@ Library Dhall.Syntax.Instances.Semigroup Dhall.Syntax.Instances.Show Dhall.Syntax.Instances.Traversable + Dhall.Syntax.MultiLet Dhall.Syntax.Operations Dhall.Syntax.Types Dhall.Syntax.Var diff --git a/dhall/src/Dhall/Syntax.hs b/dhall/src/Dhall/Syntax.hs index 0a0a293ec..d3a133feb 100644 --- a/dhall/src/Dhall/Syntax.hs +++ b/dhall/src/Dhall/Syntax.hs @@ -20,6 +20,7 @@ import Dhall.Syntax.Instances.Pretty as Export import Dhall.Syntax.Instances.Semigroup as Export () import Dhall.Syntax.Instances.Show as Export () import Dhall.Syntax.Instances.Traversable as Export () +import Dhall.Syntax.MultiLet as Export import Dhall.Syntax.Operations as Export import Dhall.Syntax.Types as Export import Dhall.Syntax.Var as Export diff --git a/dhall/src/Dhall/Syntax/MultiLet.hs b/dhall/src/Dhall/Syntax/MultiLet.hs new file mode 100644 index 000000000..e563c3851 --- /dev/null +++ b/dhall/src/Dhall/Syntax/MultiLet.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE LambdaCase #-} + +{- | Instead of converting explicitly between 'Expr's and 'MultiLet', it might +be nicer to use a pattern synonym: + +> pattern MultiLet' :: NonEmpty (Binding s a) -> Expr s a -> Expr s a +> pattern MultiLet' as b <- (multiLetFromExpr -> Just (MultiLet as b)) where +> MultiLet' as b = wrapInLets as b +> +> multiLetFromExpr :: Expr s a -> Maybe (MultiLet s a) +> multiLetFromExpr = \case +> Let x mA a b -> Just (multiLet x mA a b) +> _ -> Nothing + +This works in principle, but GHC as of v8.8.1 doesn't handle it well: +https://gitlab.haskell.org/ghc/ghc/issues/17096 + +This should be fixed by GHC-8.10, so it might be worth revisiting then. +-} + +module Dhall.Syntax.MultiLet ( + MultiLet(..) + , multiLet + , wrapInLets + ) where + +import Data.List.NonEmpty (NonEmpty (..)) +import Dhall.Syntax.Expr (Expr (..)) +import Dhall.Syntax.Types (Binding) + +import qualified Data.List.NonEmpty as NonEmpty + +{-| Generate a 'MultiLet' from the contents of a 'Let'. + + In the resulting @'MultiLet' bs e@, @e@ is guaranteed not to be a 'Let', + but it might be a @('Note' … ('Let' …))@. + + Given parser output, 'multiLet' consolidates @let@s that formed a + let-block in the original source. +-} +multiLet :: Binding s a -> Expr s a -> MultiLet s a +multiLet b0 = \case + Let b1 e1 -> + let MultiLet bs e = multiLet b1 e1 + in MultiLet (NonEmpty.cons b0 bs) e + e -> MultiLet (b0 :| []) e + +{-| Wrap let-'Binding's around an 'Expr'. + +'wrapInLets' can be understood as an inverse for 'multiLet': + +> let MultiLet bs e1 = multiLet b e0 +> +> wrapInLets bs e1 == Let b e0 +-} +wrapInLets :: Foldable f => f (Binding s a) -> Expr s a -> Expr s a +wrapInLets bs e = foldr Let e bs + +{-| This type represents 1 or more nested `Let` bindings that have been + coalesced together for ease of manipulation +-} +data MultiLet s a = MultiLet (NonEmpty (Binding s a)) (Expr s a) diff --git a/dhall/src/Dhall/Syntax/Types.hs b/dhall/src/Dhall/Syntax/Types.hs index 5f5d4d823..38f04992f 100644 --- a/dhall/src/Dhall/Syntax/Types.hs +++ b/dhall/src/Dhall/Syntax/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} {-| This module contains the core syntax types. -} @@ -19,22 +18,14 @@ module Dhall.Syntax.Types ( , FieldSelection(..) , makeFieldSelection , WithComponent(..) - - -- ** 'Let'-blocks - , MultiLet(..) - , multiLet - , wrapInLets ) where -import Data.List.NonEmpty (NonEmpty (..)) import Data.String (IsString (..)) import Data.Text (Text) import {-# SOURCE #-} Dhall.Pretty.Internal (CharacterSet (..)) import Dhall.Syntax.Expr (Expr (..)) import GHC.Generics (Generic) -import qualified Data.List.NonEmpty as NonEmpty - -- $setup -- >>> import Dhall.Binary () -- For the orphan instance for `Serialise (Expr Void Import)` @@ -209,53 +200,3 @@ makeFieldSelection t = FieldSelection Nothing t Nothing -- | A path component for a @with@ expression data WithComponent = WithLabel Text | WithQuestion deriving Generic - -{- -Instead of converting explicitly between 'Expr's and 'MultiLet', it might -be nicer to use a pattern synonym: - -> pattern MultiLet' :: NonEmpty (Binding s a) -> Expr s a -> Expr s a -> pattern MultiLet' as b <- (multiLetFromExpr -> Just (MultiLet as b)) where -> MultiLet' as b = wrapInLets as b -> -> multiLetFromExpr :: Expr s a -> Maybe (MultiLet s a) -> multiLetFromExpr = \case -> Let x mA a b -> Just (multiLet x mA a b) -> _ -> Nothing - -This works in principle, but GHC as of v8.8.1 doesn't handle it well: -https://gitlab.haskell.org/ghc/ghc/issues/17096 - -This should be fixed by GHC-8.10, so it might be worth revisiting then. --} - -{-| Generate a 'MultiLet' from the contents of a 'Let'. - - In the resulting @'MultiLet' bs e@, @e@ is guaranteed not to be a 'Let', - but it might be a @('Note' … ('Let' …))@. - - Given parser output, 'multiLet' consolidates @let@s that formed a - let-block in the original source. --} -multiLet :: Binding s a -> Expr s a -> MultiLet s a -multiLet b0 = \case - Let b1 e1 -> - let MultiLet bs e = multiLet b1 e1 - in MultiLet (NonEmpty.cons b0 bs) e - e -> MultiLet (b0 :| []) e - -{-| Wrap let-'Binding's around an 'Expr'. - -'wrapInLets' can be understood as an inverse for 'multiLet': - -> let MultiLet bs e1 = multiLet b e0 -> -> wrapInLets bs e1 == Let b e0 --} -wrapInLets :: Foldable f => f (Binding s a) -> Expr s a -> Expr s a -wrapInLets bs e = foldr Let e bs - -{-| This type represents 1 or more nested `Let` bindings that have been - coalesced together for ease of manipulation --} -data MultiLet s a = MultiLet (NonEmpty (Binding s a)) (Expr s a) From 49b6c3aebc7a4e16722d7106596da4750423c85a Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 15 Sep 2022 17:15:45 +0200 Subject: [PATCH 04/13] Moved Binding to Dhall.Syntax.Binding --- dhall/dhall.cabal | 1 + dhall/src/Dhall/Syntax.hs | 1 + dhall/src/Dhall/Syntax/Binding.hs | 60 +++++++++++++++++++ dhall/src/Dhall/Syntax/Expr.hs | 1 + .../src/Dhall/Syntax/Instances/Applicative.hs | 1 + dhall/src/Dhall/Syntax/Instances/Bifunctor.hs | 1 + dhall/src/Dhall/Syntax/Instances/Data.hs | 1 + dhall/src/Dhall/Syntax/Instances/Eq.hs | 1 + dhall/src/Dhall/Syntax/Instances/Foldable.hs | 1 + dhall/src/Dhall/Syntax/Instances/Functor.hs | 1 + dhall/src/Dhall/Syntax/Instances/Lift.hs | 1 + dhall/src/Dhall/Syntax/Instances/NFData.hs | 1 + dhall/src/Dhall/Syntax/Instances/Ord.hs | 1 + dhall/src/Dhall/Syntax/Instances/Show.hs | 1 + .../src/Dhall/Syntax/Instances/Traversable.hs | 1 + dhall/src/Dhall/Syntax/MultiLet.hs | 2 +- dhall/src/Dhall/Syntax/Operations.hs | 18 +----- dhall/src/Dhall/Syntax/Types.hs | 32 +--------- dhall/src/Dhall/Syntax/Types.hs-boot | 2 - 19 files changed, 77 insertions(+), 51 deletions(-) create mode 100644 dhall/src/Dhall/Syntax/Binding.hs diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index d7a822f67..ce0ad5586 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -360,6 +360,7 @@ Library Dhall.Parser.Combinators Dhall.Pretty.Internal Dhall.Syntax + Dhall.Syntax.Binding Dhall.Syntax.Const Dhall.Syntax.Expr Dhall.Syntax.Import diff --git a/dhall/src/Dhall/Syntax.hs b/dhall/src/Dhall/Syntax.hs index d3a133feb..989ba396a 100644 --- a/dhall/src/Dhall/Syntax.hs +++ b/dhall/src/Dhall/Syntax.hs @@ -2,6 +2,7 @@ module Dhall.Syntax ( module Export ) where +import Dhall.Syntax.Binding as Export import Dhall.Syntax.Const as Export import Dhall.Syntax.Expr as Export import Dhall.Syntax.Import as Export diff --git a/dhall/src/Dhall/Syntax/Binding.hs b/dhall/src/Dhall/Syntax/Binding.hs new file mode 100644 index 000000000..f2a4d6e4e --- /dev/null +++ b/dhall/src/Dhall/Syntax/Binding.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveGeneric #-} + +{-| This module contains the core syntax types. +-} + +module Dhall.Syntax.Binding ( + Binding(..) + , makeBinding + + -- * Optics + , bindingExprs + ) where + +import Data.Text (Text) +import {-# SOURCE #-} Dhall.Syntax.Expr (Expr) +import GHC.Generics (Generic) + +-- | Record the binding part of a @let@ expression. +-- +-- For example, +-- +-- > let {- A -} x {- B -} : {- C -} Bool = {- D -} True in x +-- +-- … will be instantiated as follows: +-- +-- * @bindingSrc0@ corresponds to the @A@ comment. +-- * @variable@ is @"x"@ +-- * @bindingSrc1@ corresponds to the @B@ comment. +-- * @annotation@ is 'Just' a pair, corresponding to the @C@ comment and @Bool@. +-- * @bindingSrc2@ corresponds to the @D@ comment. +-- * @value@ corresponds to @True@. +data Binding s a = Binding + { bindingSrc0 :: Maybe s + , variable :: Text + , bindingSrc1 :: Maybe s + , annotation :: Maybe (Maybe s, Expr s a) + , bindingSrc2 :: Maybe s + , value :: Expr s a + } deriving Generic + +{-| Construct a 'Binding' with no source information and no type annotation. +-} +makeBinding :: Text -> Expr s a -> Binding s a +makeBinding name = Binding Nothing name Nothing Nothing Nothing + +{-| Traverse over the immediate 'Expr' children in a 'Binding'. +-} +bindingExprs + :: (Applicative f) + => (Expr s a -> f (Expr s b)) + -> Binding s a -> f (Binding s b) +bindingExprs f (Binding s0 n s1 t s2 v) = + Binding + <$> pure s0 + <*> pure n + <*> pure s1 + <*> traverse (traverse f) t + <*> pure s2 + <*> f v +{-# INLINABLE bindingExprs #-} diff --git a/dhall/src/Dhall/Syntax/Expr.hs b/dhall/src/Dhall/Syntax/Expr.hs index 62c544b4d..fd9bdf1f3 100644 --- a/dhall/src/Dhall/Syntax/Expr.hs +++ b/dhall/src/Dhall/Syntax/Expr.hs @@ -17,6 +17,7 @@ import Data.Text (Text) import Data.Traversable () import Dhall.Map (Map) import {-# SOURCE #-} Dhall.Pretty.Internal (CharacterSet (..)) +import Dhall.Syntax.Binding import Dhall.Syntax.Const import {-# SOURCE #-} Dhall.Syntax.Types import Dhall.Syntax.Var diff --git a/dhall/src/Dhall/Syntax/Instances/Applicative.hs b/dhall/src/Dhall/Syntax/Instances/Applicative.hs index 07d5dccfc..c22d4d6fb 100644 --- a/dhall/src/Dhall/Syntax/Instances/Applicative.hs +++ b/dhall/src/Dhall/Syntax/Instances/Applicative.hs @@ -2,6 +2,7 @@ module Dhall.Syntax.Instances.Applicative () where +import Dhall.Syntax.Binding import Dhall.Syntax.Expr import Dhall.Syntax.Operations import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs b/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs index d1211371c..827a938af 100644 --- a/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs +++ b/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs @@ -3,6 +3,7 @@ module Dhall.Syntax.Instances.Bifunctor () where import Data.Bifunctor (Bifunctor (..)) +import Dhall.Syntax.Binding import Dhall.Syntax.Expr import Dhall.Syntax.Operations import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Data.hs b/dhall/src/Dhall/Syntax/Instances/Data.hs index 53648fe68..9de94dfbc 100644 --- a/dhall/src/Dhall/Syntax/Instances/Data.hs +++ b/dhall/src/Dhall/Syntax/Instances/Data.hs @@ -6,6 +6,7 @@ module Dhall.Syntax.Instances.Data () where import Data.Data (Data) +import Dhall.Syntax.Binding import Dhall.Syntax.Const import Dhall.Syntax.Expr import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Eq.hs b/dhall/src/Dhall/Syntax/Instances/Eq.hs index 207955b6f..a2d2fc27e 100644 --- a/dhall/src/Dhall/Syntax/Instances/Eq.hs +++ b/dhall/src/Dhall/Syntax/Instances/Eq.hs @@ -5,6 +5,7 @@ module Dhall.Syntax.Instances.Eq () where import Data.Bits (xor) +import Dhall.Syntax.Binding import Dhall.Syntax.Const import Dhall.Syntax.Expr import Dhall.Syntax.Import diff --git a/dhall/src/Dhall/Syntax/Instances/Foldable.hs b/dhall/src/Dhall/Syntax/Instances/Foldable.hs index f4b815238..7060e34b7 100644 --- a/dhall/src/Dhall/Syntax/Instances/Foldable.hs +++ b/dhall/src/Dhall/Syntax/Instances/Foldable.hs @@ -5,6 +5,7 @@ module Dhall.Syntax.Instances.Foldable () where +import Dhall.Syntax.Binding import Dhall.Syntax.Expr import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Functor.hs b/dhall/src/Dhall/Syntax/Instances/Functor.hs index 35a12425f..31496e854 100644 --- a/dhall/src/Dhall/Syntax/Instances/Functor.hs +++ b/dhall/src/Dhall/Syntax/Instances/Functor.hs @@ -5,6 +5,7 @@ module Dhall.Syntax.Instances.Functor () where +import Dhall.Syntax.Binding import Dhall.Syntax.Expr import {-# SOURCE #-} Dhall.Syntax.Operations (unsafeSubExpressions) import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Lift.hs b/dhall/src/Dhall/Syntax/Instances/Lift.hs index db22ca809..f606c0f1f 100644 --- a/dhall/src/Dhall/Syntax/Instances/Lift.hs +++ b/dhall/src/Dhall/Syntax/Instances/Lift.hs @@ -5,6 +5,7 @@ module Dhall.Syntax.Instances.Lift () where +import Dhall.Syntax.Binding import Dhall.Syntax.Const import Dhall.Syntax.Expr import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/NFData.hs b/dhall/src/Dhall/Syntax/Instances/NFData.hs index 3fb03cd66..b5cef682a 100644 --- a/dhall/src/Dhall/Syntax/Instances/NFData.hs +++ b/dhall/src/Dhall/Syntax/Instances/NFData.hs @@ -3,6 +3,7 @@ module Dhall.Syntax.Instances.NFData () where import Control.DeepSeq (NFData) +import Dhall.Syntax.Binding import Dhall.Syntax.Const import Dhall.Syntax.Expr import Dhall.Syntax.Import diff --git a/dhall/src/Dhall/Syntax/Instances/Ord.hs b/dhall/src/Dhall/Syntax/Instances/Ord.hs index 6d747ee8f..cb6388add 100644 --- a/dhall/src/Dhall/Syntax/Instances/Ord.hs +++ b/dhall/src/Dhall/Syntax/Instances/Ord.hs @@ -4,6 +4,7 @@ module Dhall.Syntax.Instances.Ord () where +import Dhall.Syntax.Binding import Dhall.Syntax.Const import Dhall.Syntax.Expr import Dhall.Syntax.Import diff --git a/dhall/src/Dhall/Syntax/Instances/Show.hs b/dhall/src/Dhall/Syntax/Instances/Show.hs index 9b4570184..7d3ee0950 100644 --- a/dhall/src/Dhall/Syntax/Instances/Show.hs +++ b/dhall/src/Dhall/Syntax/Instances/Show.hs @@ -4,6 +4,7 @@ module Dhall.Syntax.Instances.Show () where +import Dhall.Syntax.Binding import Dhall.Syntax.Const import Dhall.Syntax.Expr import Dhall.Syntax.Import diff --git a/dhall/src/Dhall/Syntax/Instances/Traversable.hs b/dhall/src/Dhall/Syntax/Instances/Traversable.hs index 6d483de6a..fce248ccf 100644 --- a/dhall/src/Dhall/Syntax/Instances/Traversable.hs +++ b/dhall/src/Dhall/Syntax/Instances/Traversable.hs @@ -5,6 +5,7 @@ module Dhall.Syntax.Instances.Traversable () where +import Dhall.Syntax.Binding import Dhall.Syntax.Expr import Dhall.Syntax.Instances.Foldable () import Dhall.Syntax.Instances.Functor () diff --git a/dhall/src/Dhall/Syntax/MultiLet.hs b/dhall/src/Dhall/Syntax/MultiLet.hs index e563c3851..7a5198d0a 100644 --- a/dhall/src/Dhall/Syntax/MultiLet.hs +++ b/dhall/src/Dhall/Syntax/MultiLet.hs @@ -26,7 +26,7 @@ module Dhall.Syntax.MultiLet ( import Data.List.NonEmpty (NonEmpty (..)) import Dhall.Syntax.Expr (Expr (..)) -import Dhall.Syntax.Types (Binding) +import Dhall.Syntax.Binding (Binding) import qualified Data.List.NonEmpty as NonEmpty diff --git a/dhall/src/Dhall/Syntax/Operations.hs b/dhall/src/Dhall/Syntax/Operations.hs index fda61ac54..90fc79ac4 100644 --- a/dhall/src/Dhall/Syntax/Operations.hs +++ b/dhall/src/Dhall/Syntax/Operations.hs @@ -8,7 +8,6 @@ module Dhall.Syntax.Operations ( , subExpressionsWith , unsafeSubExpressions , chunkExprs - , bindingExprs , recordFieldExprs , functionBindingExprs @@ -39,6 +38,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) import Data.Void (Void) import Dhall.Src (Src (..)) +import Dhall.Syntax.Binding (Binding(..), bindingExprs) import Dhall.Syntax.Expr import Dhall.Syntax.Instances.Monoid () import Dhall.Syntax.Types @@ -175,22 +175,6 @@ unhandledConstructor constructor = <> " construtor" ) -{-| Traverse over the immediate 'Expr' children in a 'Binding'. --} -bindingExprs - :: (Applicative f) - => (Expr s a -> f (Expr s b)) - -> Binding s a -> f (Binding s b) -bindingExprs f (Binding s0 n s1 t s2 v) = - Binding - <$> pure s0 - <*> pure n - <*> pure s1 - <*> traverse (traverse f) t - <*> pure s2 - <*> f v -{-# INLINABLE bindingExprs #-} - {-| Traverse over the immediate 'Expr' children in a 'RecordField'. -} recordFieldExprs diff --git a/dhall/src/Dhall/Syntax/Types.hs b/dhall/src/Dhall/Syntax/Types.hs index 38f04992f..1a6ebf07e 100644 --- a/dhall/src/Dhall/Syntax/Types.hs +++ b/dhall/src/Dhall/Syntax/Types.hs @@ -5,9 +5,7 @@ module Dhall.Syntax.Types ( -- * 'Expr' - Binding(..) - , makeBinding - , CharacterSet(..) + CharacterSet(..) , Chunks(..) , DhallDouble(..) , PreferAnnotation(..) @@ -29,34 +27,6 @@ import GHC.Generics (Generic) -- $setup -- >>> import Dhall.Binary () -- For the orphan instance for `Serialise (Expr Void Import)` --- | Record the binding part of a @let@ expression. --- --- For example, --- --- > let {- A -} x {- B -} : {- C -} Bool = {- D -} True in x --- --- … will be instantiated as follows: --- --- * @bindingSrc0@ corresponds to the @A@ comment. --- * @variable@ is @"x"@ --- * @bindingSrc1@ corresponds to the @B@ comment. --- * @annotation@ is 'Just' a pair, corresponding to the @C@ comment and @Bool@. --- * @bindingSrc2@ corresponds to the @D@ comment. --- * @value@ corresponds to @True@. -data Binding s a = Binding - { bindingSrc0 :: Maybe s - , variable :: Text - , bindingSrc1 :: Maybe s - , annotation :: Maybe (Maybe s, Expr s a) - , bindingSrc2 :: Maybe s - , value :: Expr s a - } deriving Generic - -{-| Construct a 'Binding' with no source information and no type annotation. --} -makeBinding :: Text -> Expr s a -> Binding s a -makeBinding name = Binding Nothing name Nothing Nothing Nothing - -- | This wrapper around 'Prelude.Double' exists for its 'Eq' instance which is -- defined via the binary encoding of Dhall @Double@s. newtype DhallDouble = DhallDouble { getDhallDouble :: Double } diff --git a/dhall/src/Dhall/Syntax/Types.hs-boot b/dhall/src/Dhall/Syntax/Types.hs-boot index 992f02ed7..4e4320048 100644 --- a/dhall/src/Dhall/Syntax/Types.hs-boot +++ b/dhall/src/Dhall/Syntax/Types.hs-boot @@ -1,7 +1,5 @@ module Dhall.Syntax.Types where -data Binding s a - data DhallDouble data Chunks s a From 9a916e28a69750061fea58143b9e8e8afdfbce1d Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 16 Sep 2022 12:31:31 +0200 Subject: [PATCH 05/13] Moved Chunks to Dhall.Syntax.Chunks --- dhall/dhall.cabal | 5 +- dhall/src/Dhall.hs | 24 +-- dhall/src/Dhall/Core.hs | 2 +- dhall/src/Dhall/Import.hs | 2 +- dhall/src/Dhall/Import/Headers.hs | 25 ++- dhall/src/Dhall/Normalize.hs | 2 +- dhall/src/Dhall/Pretty/Internal.hs | 33 ++-- dhall/src/Dhall/Syntax.hs | 3 +- dhall/src/Dhall/Syntax/Binding.hs | 6 +- dhall/src/Dhall/Syntax/Chunks.hs | 144 ++++++++++++++++++ dhall/src/Dhall/Syntax/Chunks.hs-boot | 3 + dhall/src/Dhall/Syntax/Expr.hs | 1 + dhall/src/Dhall/Syntax/Import.hs | 57 ++++++- .../src/Dhall/Syntax/Instances/Applicative.hs | 1 + dhall/src/Dhall/Syntax/Instances/Bifunctor.hs | 3 +- dhall/src/Dhall/Syntax/Instances/Data.hs | 3 +- dhall/src/Dhall/Syntax/Instances/Eq.hs | 3 +- dhall/src/Dhall/Syntax/Instances/Foldable.hs | 1 + dhall/src/Dhall/Syntax/Instances/Functor.hs | 1 + dhall/src/Dhall/Syntax/Instances/Lift.hs | 1 + dhall/src/Dhall/Syntax/Instances/Monoid.hs | 9 -- dhall/src/Dhall/Syntax/Instances/NFData.hs | 3 +- dhall/src/Dhall/Syntax/Instances/Ord.hs | 1 + dhall/src/Dhall/Syntax/Instances/Semigroup.hs | 57 ------- dhall/src/Dhall/Syntax/Instances/Show.hs | 1 + .../src/Dhall/Syntax/Instances/Traversable.hs | 1 + dhall/src/Dhall/Syntax/MultiLet.hs | 8 +- dhall/src/Dhall/Syntax/Operations.hs | 125 +-------------- dhall/src/Dhall/Syntax/Types.hs | 9 -- dhall/src/Dhall/Syntax/Types.hs-boot | 2 - 30 files changed, 278 insertions(+), 258 deletions(-) create mode 100644 dhall/src/Dhall/Syntax/Chunks.hs create mode 100644 dhall/src/Dhall/Syntax/Chunks.hs-boot delete mode 100644 dhall/src/Dhall/Syntax/Instances/Monoid.hs delete mode 100644 dhall/src/Dhall/Syntax/Instances/Semigroup.hs diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index ce0ad5586..b9d8ade93 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -361,6 +361,7 @@ Library Dhall.Pretty.Internal Dhall.Syntax Dhall.Syntax.Binding + Dhall.Syntax.Chunks Dhall.Syntax.Const Dhall.Syntax.Expr Dhall.Syntax.Import @@ -372,11 +373,11 @@ Library Dhall.Syntax.Instances.Functor Dhall.Syntax.Instances.Lift Dhall.Syntax.Instances.Monad - Dhall.Syntax.Instances.Monoid + -- Dhall.Syntax.Instances.Monoid Dhall.Syntax.Instances.NFData Dhall.Syntax.Instances.Ord Dhall.Syntax.Instances.Pretty - Dhall.Syntax.Instances.Semigroup + --Dhall.Syntax.Instances.Semigroup Dhall.Syntax.Instances.Show Dhall.Syntax.Instances.Traversable Dhall.Syntax.MultiLet diff --git a/dhall/src/Dhall.hs b/dhall/src/Dhall.hs index 0bb8954af..e2d11dcbe 100644 --- a/dhall/src/Dhall.hs +++ b/dhall/src/Dhall.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-| Please read the "Dhall.Tutorial" module, which contains a tutorial explaining how to use the language, the compiler, and this library diff --git a/dhall/src/Dhall/Core.hs b/dhall/src/Dhall/Core.hs index 1d52884bf..8b8b39340 100644 --- a/dhall/src/Dhall/Core.hs +++ b/dhall/src/Dhall/Core.hs @@ -92,7 +92,7 @@ import Prettyprinter (Pretty) import qualified Control.Exception import qualified Data.Text -import qualified Dhall.Eval as Eval +import qualified Dhall.Eval as Eval -- | Pretty-print a value pretty :: Pretty a => a -> Text diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 065dde767..8a6cde426 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -235,8 +235,8 @@ import qualified System.AtomicWrite.Writer.ByteString.Binary as AtomicWrite.Bina import qualified System.Directory as Directory import qualified System.Environment import qualified System.FilePath as FilePath -import qualified System.IO import qualified System.Info +import qualified System.IO import qualified Text.Megaparsec import qualified Text.Parser.Combinators import qualified Text.Parser.Token diff --git a/dhall/src/Dhall/Import/Headers.hs b/dhall/src/Dhall/Import/Headers.hs index 1009c2c88..e61f2dcb7 100644 --- a/dhall/src/Dhall/Import/Headers.hs +++ b/dhall/src/Dhall/Import/Headers.hs @@ -9,26 +9,23 @@ module Dhall.Import.Headers , toOriginHeaders ) where -import Control.Applicative (Alternative (..), liftA2) -import Control.Exception (SomeException) -import Control.Monad.Catch (handle, throwM) -import Data.Text (Text) -import Data.Void (Void) -import Dhall.Core - ( Chunks (..) - , Expr (..) - ) -import Dhall.Import.Types (HTTPHeader , OriginHeaders) -import Dhall.Parser (Src (..)) +import Control.Applicative (Alternative (..), liftA2) +import Control.Exception (SomeException) +import Control.Monad.Catch (handle, throwM) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Core (Chunks (..), Expr (..)) +import Dhall.Import.Types (HTTPHeader, OriginHeaders) +import Dhall.Parser (Src (..)) import qualified Data.CaseInsensitive import qualified Data.Foldable -import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashMap.Strict as HashMap import qualified Data.Text.Encoding -import qualified Dhall.Core as Core +import qualified Dhall.Core as Core import qualified Dhall.Map -import qualified Dhall.TypeCheck import qualified Dhall.Pretty.Internal +import qualified Dhall.TypeCheck -- | Given a well-typed (of type `List { header : Text, value Text }` or -- `List { mapKey : Text, mapValue Text }`) headers expressions in normal form diff --git a/dhall/src/Dhall/Normalize.hs b/dhall/src/Dhall/Normalize.hs index 7e5b91b96..e49d5ef39 100644 --- a/dhall/src/Dhall/Normalize.hs +++ b/dhall/src/Dhall/Normalize.hs @@ -38,8 +38,8 @@ import Dhall.Syntax , FunctionBinding (..) , PreferAnnotation (..) , RecordField (..) - , WithComponent (..) , Var (..) + , WithComponent (..) ) import qualified Data.Sequence diff --git a/dhall/src/Dhall/Pretty/Internal.hs b/dhall/src/Dhall/Pretty/Internal.hs index df750b991..3ab067332 100644 --- a/dhall/src/Dhall/Pretty/Internal.hs +++ b/dhall/src/Dhall/Pretty/Internal.hs @@ -72,22 +72,25 @@ module Dhall.Pretty.Internal ( , temporalToText ) where -import Control.DeepSeq (NFData) -import Data.Aeson (FromJSON (..), Value (String)) -import Data.Aeson.Types (typeMismatch, unexpected) -import Data.Data (Data) -import Data.Foldable -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Text (Text) -import Dhall.Map (Map) -import Dhall.Optics (cosmosOf, foldOf, to) -import Dhall.Src (Src (..)) -import Dhall.Syntax +import Control.DeepSeq (NFData) +import Data.Aeson + ( FromJSON (..) + , Value (String) + ) +import Data.Aeson.Types (typeMismatch, unexpected) +import Data.Data (Data) +import Data.Foldable +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import Dhall.Map (Map) +import Dhall.Optics (cosmosOf, foldOf, to) +import Dhall.Src (Src (..)) +import Dhall.Syntax import {-# SOURCE #-} Dhall.Syntax.Instances.Pretty () -import GHC.Generics (Generic) -import Language.Haskell.TH.Syntax (Lift) -import Numeric.Natural (Natural) -import Prettyprinter (Doc, Pretty, space) +import GHC.Generics (Generic) +import Language.Haskell.TH.Syntax (Lift) +import Numeric.Natural (Natural) +import Prettyprinter (Doc, Pretty, space) import qualified Data.Char import qualified Data.HashSet diff --git a/dhall/src/Dhall/Syntax.hs b/dhall/src/Dhall/Syntax.hs index 989ba396a..ceb704af8 100644 --- a/dhall/src/Dhall/Syntax.hs +++ b/dhall/src/Dhall/Syntax.hs @@ -3,6 +3,7 @@ module Dhall.Syntax ) where import Dhall.Syntax.Binding as Export +import Dhall.Syntax.Chunks as Export import Dhall.Syntax.Const as Export import Dhall.Syntax.Expr as Export import Dhall.Syntax.Import as Export @@ -14,11 +15,9 @@ import Dhall.Syntax.Instances.Foldable as Export () import Dhall.Syntax.Instances.Functor as Export () import Dhall.Syntax.Instances.Lift as Export () import Dhall.Syntax.Instances.Monad as Export () -import Dhall.Syntax.Instances.Monoid as Export () import Dhall.Syntax.Instances.NFData as Export () import Dhall.Syntax.Instances.Ord as Export () import Dhall.Syntax.Instances.Pretty as Export -import Dhall.Syntax.Instances.Semigroup as Export () import Dhall.Syntax.Instances.Show as Export () import Dhall.Syntax.Instances.Traversable as Export () import Dhall.Syntax.MultiLet as Export diff --git a/dhall/src/Dhall/Syntax/Binding.hs b/dhall/src/Dhall/Syntax/Binding.hs index f2a4d6e4e..30c350978 100644 --- a/dhall/src/Dhall/Syntax/Binding.hs +++ b/dhall/src/Dhall/Syntax/Binding.hs @@ -11,9 +11,9 @@ module Dhall.Syntax.Binding ( , bindingExprs ) where -import Data.Text (Text) -import {-# SOURCE #-} Dhall.Syntax.Expr (Expr) -import GHC.Generics (Generic) +import Data.Text (Text) +import {-# SOURCE #-} Dhall.Syntax.Expr (Expr) +import GHC.Generics (Generic) -- | Record the binding part of a @let@ expression. -- diff --git a/dhall/src/Dhall/Syntax/Chunks.hs b/dhall/src/Dhall/Syntax/Chunks.hs new file mode 100644 index 000000000..42f77873a --- /dev/null +++ b/dhall/src/Dhall/Syntax/Chunks.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| This module contains the core syntax types. +-} + +module Dhall.Syntax.Chunks ( + Chunks(..) + + -- * Optics + , chunkExprs + + -- * `Data.Text.Text` manipulation + , toDoubleQuoted + , longestSharedWhitespacePrefix + , linesLiteral + , unlinesLiteral + ) where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.String (IsString (..)) +import Data.Text (Text) +import Dhall.Src (Src) +import {-# SOURCE #-} Dhall.Syntax.Expr (Expr) +import GHC.Generics (Generic) + +import qualified Data.Foldable +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Text + +-- | The body of an interpolated @Text@ literal +data Chunks s a = Chunks [(Text, Expr s a)] Text + deriving Generic + +instance IsString (Chunks s a) where + fromString str = Chunks [] (fromString str) + +instance Semigroup (Chunks s a) where + Chunks xysL zL <> Chunks [] zR = + Chunks xysL (zL <> zR) + Chunks xysL zL <> Chunks ((x, y):xysR) zR = + Chunks (xysL ++ (zL <> x, y):xysR) zR + +instance Monoid (Chunks s a) where + mempty = Chunks [] mempty + +-- | A traversal over the immediate sub-expressions in 'Chunks'. +chunkExprs + :: Applicative f + => (Expr s a -> f (Expr t b)) + -> Chunks s a -> f (Chunks t b) +chunkExprs f (Chunks chunks final) = + flip Chunks final <$> traverse (traverse f) chunks +{-# INLINABLE chunkExprs #-} + +-- | Same as @Data.Text.splitOn@, except always returning a `NonEmpty` result +splitOn :: Text -> Text -> NonEmpty Text +splitOn needle haystack = + case Data.Text.splitOn needle haystack of + [] -> "" :| [] + t : ts -> t :| ts + +-- | Split `Chunks` by lines +linesLiteral :: Chunks s a -> NonEmpty (Chunks s a) +linesLiteral (Chunks [] suffix) = + fmap (Chunks []) (splitOn "\n" suffix) +linesLiteral (Chunks ((prefix, interpolation) : pairs₀) suffix₀) = + foldr + NonEmpty.cons + (Chunks ((lastLine, interpolation) : pairs₁) suffix₁ :| chunks) + (fmap (Chunks []) initLines) + where + splitLines = splitOn "\n" prefix + + initLines = NonEmpty.init splitLines + lastLine = NonEmpty.last splitLines + + Chunks pairs₁ suffix₁ :| chunks = linesLiteral (Chunks pairs₀ suffix₀) + +-- | Flatten several `Chunks` back into a single `Chunks` by inserting newlines +unlinesLiteral :: NonEmpty (Chunks s a) -> Chunks s a +unlinesLiteral chunks = + Data.Foldable.fold (NonEmpty.intersperse "\n" chunks) + +-- | Returns `True` if the `Chunks` represents a blank line +emptyLine :: Chunks s a -> Bool +emptyLine (Chunks [] "" ) = True +emptyLine (Chunks [] "\r") = True -- So that `\r\n` is treated as a blank line +emptyLine _ = False + +-- | Return the leading whitespace for a `Chunks` literal +leadingSpaces :: Chunks s a -> Text +leadingSpaces chunks = Data.Text.takeWhile isSpace firstText + where + isSpace c = c == ' ' || c == '\t' + + firstText = + case chunks of + Chunks [] suffix -> suffix + Chunks ((prefix, _) : _ ) _ -> prefix + +{-| Compute the longest shared whitespace prefix for the purposes of stripping + leading indentation +-} +longestSharedWhitespacePrefix :: NonEmpty (Chunks s a) -> Text +longestSharedWhitespacePrefix literals = + case fmap leadingSpaces filteredLines of + l : ls -> Data.Foldable.foldl' sharedPrefix l ls + [] -> "" + where + sharedPrefix ab ac = + case Data.Text.commonPrefixes ab ac of + Just (a, _b, _c) -> a + Nothing -> "" + + -- The standard specifies to filter out blank lines for all lines *except* + -- for the last line + filteredLines = newInit <> pure oldLast + where + oldInit = NonEmpty.init literals + + oldLast = NonEmpty.last literals + + newInit = filter (not . emptyLine) oldInit + +-- | Drop the first @n@ characters for a `Chunks` literal +dropLiteral :: Int -> Chunks s a -> Chunks s a +dropLiteral n (Chunks [] suffix) = + Chunks [] (Data.Text.drop n suffix) +dropLiteral n (Chunks ((prefix, interpolation) : rest) suffix) = + Chunks ((Data.Text.drop n prefix, interpolation) : rest) suffix + +{-| Convert a single-quoted `Chunks` literal to the equivalent double-quoted + `Chunks` literal +-} +toDoubleQuoted :: Chunks Src a -> Chunks Src a +toDoubleQuoted literal = + unlinesLiteral (fmap (dropLiteral indent) literals) + where + literals = linesLiteral literal + + longestSharedPrefix = longestSharedWhitespacePrefix literals + + indent = Data.Text.length longestSharedPrefix diff --git a/dhall/src/Dhall/Syntax/Chunks.hs-boot b/dhall/src/Dhall/Syntax/Chunks.hs-boot new file mode 100644 index 000000000..23070a09c --- /dev/null +++ b/dhall/src/Dhall/Syntax/Chunks.hs-boot @@ -0,0 +1,3 @@ +module Dhall.Syntax.Chunks where + +data Chunks s a diff --git a/dhall/src/Dhall/Syntax/Expr.hs b/dhall/src/Dhall/Syntax/Expr.hs index fd9bdf1f3..ee1aa385c 100644 --- a/dhall/src/Dhall/Syntax/Expr.hs +++ b/dhall/src/Dhall/Syntax/Expr.hs @@ -18,6 +18,7 @@ import Data.Traversable () import Dhall.Map (Map) import {-# SOURCE #-} Dhall.Pretty.Internal (CharacterSet (..)) import Dhall.Syntax.Binding +import Dhall.Syntax.Chunks import Dhall.Syntax.Const import {-# SOURCE #-} Dhall.Syntax.Types import Dhall.Syntax.Var diff --git a/dhall/src/Dhall/Syntax/Import.hs b/dhall/src/Dhall/Syntax/Import.hs index 843c5d82d..a44f9afc1 100644 --- a/dhall/src/Dhall/Syntax/Import.hs +++ b/dhall/src/Dhall/Syntax/Import.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-| This module contains the core syntax types. -} @@ -15,10 +17,11 @@ module Dhall.Syntax.Import ( , Scheme(..) ) where -import Data.Text (Text) -import Dhall.Src (Src (..)) -import Dhall.Syntax.Expr (Expr (..)) -import GHC.Generics (Generic) +import Data.Text (Text) +import Dhall.Src (Src (..)) +import Dhall.Syntax.Expr (Expr (..)) +import Dhall.Syntax.Instances.Functor () +import GHC.Generics (Generic) import qualified Dhall.Crypto @@ -90,3 +93,47 @@ data Import = Import { importHashed :: ImportHashed , importMode :: ImportMode } deriving Generic + + + + +instance Semigroup Directory where + Directory components0 <> Directory components1 = + Directory (components1 <> components0) + +instance Semigroup File where + File directory0 _ <> File directory1 file = + File (directory0 <> directory1) file + +instance Semigroup ImportType where + Local prefix file0 <> Local Here file1 = Local prefix (file0 <> file1) + + Remote (URL { path = path0, ..}) <> Local Here path1 = + Remote (URL { path = path0 <> path1, ..}) + + Local prefix file0 <> Local Parent file1 = + Local prefix (file0 <> parent <> file1) + + Remote (URL { path = path0, .. }) <> Local Parent path1 = + Remote (URL { path = path0 <> parent <> path1, .. }) + + import0 <> Remote (URL { headers = headers0, .. }) = + Remote (URL { headers = headers1, .. }) + where + importHashed0 = Import (ImportHashed Nothing import0) Code + + headers1 = fmap (fmap (importHashed0 <>)) headers0 + + _ <> import1 = + import1 + +instance Semigroup ImportHashed where + ImportHashed _ importType0 <> ImportHashed hash importType1 = + ImportHashed hash (importType0 <> importType1) + +instance Semigroup Import where + Import importHashed0 _ <> Import importHashed1 code = + Import (importHashed0 <> importHashed1) code + +parent :: File +parent = File { directory = Directory { components = [ ".." ] }, file = "" } diff --git a/dhall/src/Dhall/Syntax/Instances/Applicative.hs b/dhall/src/Dhall/Syntax/Instances/Applicative.hs index c22d4d6fb..445d86b55 100644 --- a/dhall/src/Dhall/Syntax/Instances/Applicative.hs +++ b/dhall/src/Dhall/Syntax/Instances/Applicative.hs @@ -4,6 +4,7 @@ module Dhall.Syntax.Instances.Applicative () where import Dhall.Syntax.Binding import Dhall.Syntax.Expr +import Dhall.Syntax.Instances.Functor () import Dhall.Syntax.Operations import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs b/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs index 827a938af..fbd4fee75 100644 --- a/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs +++ b/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs @@ -2,9 +2,10 @@ module Dhall.Syntax.Instances.Bifunctor () where -import Data.Bifunctor (Bifunctor (..)) +import Data.Bifunctor (Bifunctor (..)) import Dhall.Syntax.Binding import Dhall.Syntax.Expr +import Dhall.Syntax.Instances.Functor () import Dhall.Syntax.Operations import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Data.hs b/dhall/src/Dhall/Syntax/Instances/Data.hs index 9de94dfbc..717366b4e 100644 --- a/dhall/src/Dhall/Syntax/Instances/Data.hs +++ b/dhall/src/Dhall/Syntax/Instances/Data.hs @@ -5,8 +5,9 @@ module Dhall.Syntax.Instances.Data () where -import Data.Data (Data) +import Data.Data (Data) import Dhall.Syntax.Binding +import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Eq.hs b/dhall/src/Dhall/Syntax/Instances/Eq.hs index a2d2fc27e..8b02f0bda 100644 --- a/dhall/src/Dhall/Syntax/Instances/Eq.hs +++ b/dhall/src/Dhall/Syntax/Instances/Eq.hs @@ -4,8 +4,9 @@ module Dhall.Syntax.Instances.Eq () where -import Data.Bits (xor) +import Data.Bits (xor) import Dhall.Syntax.Binding +import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr import Dhall.Syntax.Import diff --git a/dhall/src/Dhall/Syntax/Instances/Foldable.hs b/dhall/src/Dhall/Syntax/Instances/Foldable.hs index 7060e34b7..02cbec863 100644 --- a/dhall/src/Dhall/Syntax/Instances/Foldable.hs +++ b/dhall/src/Dhall/Syntax/Instances/Foldable.hs @@ -6,6 +6,7 @@ module Dhall.Syntax.Instances.Foldable () where import Dhall.Syntax.Binding +import Dhall.Syntax.Chunks import Dhall.Syntax.Expr import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Functor.hs b/dhall/src/Dhall/Syntax/Instances/Functor.hs index 31496e854..b11c5f8fa 100644 --- a/dhall/src/Dhall/Syntax/Instances/Functor.hs +++ b/dhall/src/Dhall/Syntax/Instances/Functor.hs @@ -6,6 +6,7 @@ module Dhall.Syntax.Instances.Functor () where import Dhall.Syntax.Binding +import Dhall.Syntax.Chunks import Dhall.Syntax.Expr import {-# SOURCE #-} Dhall.Syntax.Operations (unsafeSubExpressions) import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Lift.hs b/dhall/src/Dhall/Syntax/Instances/Lift.hs index f606c0f1f..d09fdd203 100644 --- a/dhall/src/Dhall/Syntax/Instances/Lift.hs +++ b/dhall/src/Dhall/Syntax/Instances/Lift.hs @@ -6,6 +6,7 @@ module Dhall.Syntax.Instances.Lift () where import Dhall.Syntax.Binding +import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Monoid.hs b/dhall/src/Dhall/Syntax/Instances/Monoid.hs deleted file mode 100644 index 059dbd40b..000000000 --- a/dhall/src/Dhall/Syntax/Instances/Monoid.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - -module Dhall.Syntax.Instances.Monoid () where - -import Dhall.Syntax.Instances.Semigroup () -import Dhall.Syntax.Types - -instance Monoid (Chunks s a) where - mempty = Chunks [] mempty diff --git a/dhall/src/Dhall/Syntax/Instances/NFData.hs b/dhall/src/Dhall/Syntax/Instances/NFData.hs index b5cef682a..a718905e7 100644 --- a/dhall/src/Dhall/Syntax/Instances/NFData.hs +++ b/dhall/src/Dhall/Syntax/Instances/NFData.hs @@ -2,8 +2,9 @@ module Dhall.Syntax.Instances.NFData () where -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData) import Dhall.Syntax.Binding +import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr import Dhall.Syntax.Import diff --git a/dhall/src/Dhall/Syntax/Instances/Ord.hs b/dhall/src/Dhall/Syntax/Instances/Ord.hs index cb6388add..a700e53c8 100644 --- a/dhall/src/Dhall/Syntax/Instances/Ord.hs +++ b/dhall/src/Dhall/Syntax/Instances/Ord.hs @@ -5,6 +5,7 @@ module Dhall.Syntax.Instances.Ord () where import Dhall.Syntax.Binding +import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr import Dhall.Syntax.Import diff --git a/dhall/src/Dhall/Syntax/Instances/Semigroup.hs b/dhall/src/Dhall/Syntax/Instances/Semigroup.hs deleted file mode 100644 index df64bf985..000000000 --- a/dhall/src/Dhall/Syntax/Instances/Semigroup.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Dhall.Syntax.Instances.Semigroup () where - -import Dhall.Syntax.Import -import Dhall.Syntax.Instances.Functor () -import Dhall.Syntax.Types - -instance Semigroup (Chunks s a) where - Chunks xysL zL <> Chunks [] zR = - Chunks xysL (zL <> zR) - Chunks xysL zL <> Chunks ((x, y):xysR) zR = - Chunks (xysL ++ (zL <> x, y):xysR) zR - -instance Semigroup Directory where - Directory components0 <> Directory components1 = - Directory (components1 <> components0) - -instance Semigroup File where - File directory0 _ <> File directory1 file = - File (directory0 <> directory1) file - -instance Semigroup ImportType where - Local prefix file0 <> Local Here file1 = Local prefix (file0 <> file1) - - Remote (URL { path = path0, ..}) <> Local Here path1 = - Remote (URL { path = path0 <> path1, ..}) - - Local prefix file0 <> Local Parent file1 = - Local prefix (file0 <> parent <> file1) - - Remote (URL { path = path0, .. }) <> Local Parent path1 = - Remote (URL { path = path0 <> parent <> path1, .. }) - - import0 <> Remote (URL { headers = headers0, .. }) = - Remote (URL { headers = headers1, .. }) - where - importHashed0 = Import (ImportHashed Nothing import0) Code - - headers1 = fmap (fmap (importHashed0 <>)) headers0 - - _ <> import1 = - import1 - -instance Semigroup ImportHashed where - ImportHashed _ importType0 <> ImportHashed hash importType1 = - ImportHashed hash (importType0 <> importType1) - -instance Semigroup Import where - Import importHashed0 _ <> Import importHashed1 code = - Import (importHashed0 <> importHashed1) code - -parent :: File -parent = File { directory = Directory { components = [ ".." ] }, file = "" } diff --git a/dhall/src/Dhall/Syntax/Instances/Show.hs b/dhall/src/Dhall/Syntax/Instances/Show.hs index 7d3ee0950..0b3cd3635 100644 --- a/dhall/src/Dhall/Syntax/Instances/Show.hs +++ b/dhall/src/Dhall/Syntax/Instances/Show.hs @@ -5,6 +5,7 @@ module Dhall.Syntax.Instances.Show () where import Dhall.Syntax.Binding +import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr import Dhall.Syntax.Import diff --git a/dhall/src/Dhall/Syntax/Instances/Traversable.hs b/dhall/src/Dhall/Syntax/Instances/Traversable.hs index fce248ccf..db0f4c8bb 100644 --- a/dhall/src/Dhall/Syntax/Instances/Traversable.hs +++ b/dhall/src/Dhall/Syntax/Instances/Traversable.hs @@ -6,6 +6,7 @@ module Dhall.Syntax.Instances.Traversable () where import Dhall.Syntax.Binding +import Dhall.Syntax.Chunks import Dhall.Syntax.Expr import Dhall.Syntax.Instances.Foldable () import Dhall.Syntax.Instances.Functor () diff --git a/dhall/src/Dhall/Syntax/MultiLet.hs b/dhall/src/Dhall/Syntax/MultiLet.hs index 7a5198d0a..7802f1537 100644 --- a/dhall/src/Dhall/Syntax/MultiLet.hs +++ b/dhall/src/Dhall/Syntax/MultiLet.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {- | Instead of converting explicitly between 'Expr's and 'MultiLet', it might be nicer to use a pattern synonym: @@ -24,9 +24,9 @@ module Dhall.Syntax.MultiLet ( , wrapInLets ) where -import Data.List.NonEmpty (NonEmpty (..)) -import Dhall.Syntax.Expr (Expr (..)) -import Dhall.Syntax.Binding (Binding) +import Data.List.NonEmpty (NonEmpty (..)) +import Dhall.Syntax.Binding (Binding) +import Dhall.Syntax.Expr (Expr (..)) import qualified Data.List.NonEmpty as NonEmpty diff --git a/dhall/src/Dhall/Syntax/Operations.hs b/dhall/src/Dhall/Syntax/Operations.hs index 90fc79ac4..faeec990f 100644 --- a/dhall/src/Dhall/Syntax/Operations.hs +++ b/dhall/src/Dhall/Syntax/Operations.hs @@ -7,7 +7,6 @@ module Dhall.Syntax.Operations ( subExpressions , subExpressionsWith , unsafeSubExpressions - , chunkExprs , recordFieldExprs , functionBindingExprs @@ -20,12 +19,6 @@ module Dhall.Syntax.Operations ( , reservedIdentifiers , reservedKeywords - -- * `Data.Text.Text` manipulation - , toDoubleQuoted - , longestSharedWhitespacePrefix - , linesLiteral - , unlinesLiteral - -- * Utilities , internalError -- `shift` should really be in `Dhall.Normalize`, but it's here to avoid a @@ -33,23 +26,19 @@ module Dhall.Syntax.Operations ( , shift ) where -import Data.HashSet (HashSet) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Text (Text) -import Data.Void (Void) -import Dhall.Src (Src (..)) -import Dhall.Syntax.Binding (Binding(..), bindingExprs) +import Data.HashSet (HashSet) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Syntax.Binding (Binding (..), bindingExprs) +import Dhall.Syntax.Chunks (chunkExprs) import Dhall.Syntax.Expr -import Dhall.Syntax.Instances.Monoid () import Dhall.Syntax.Types import Dhall.Syntax.Var -import Unsafe.Coerce (unsafeCoerce) +import Unsafe.Coerce (unsafeCoerce) -import qualified Data.Foldable import qualified Data.HashSet -import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text -import qualified Lens.Family as Lens +import qualified Lens.Family as Lens -- | A traversal over the immediate sub-expressions of an expression. @@ -204,15 +193,6 @@ functionBindingExprs f (FunctionBinding s0 label s1 s2 type_) = <*> f type_ {-# INLINABLE functionBindingExprs #-} --- | A traversal over the immediate sub-expressions in 'Chunks'. -chunkExprs - :: Applicative f - => (Expr s a -> f (Expr t b)) - -> Chunks s a -> f (Chunks t b) -chunkExprs f (Chunks chunks final) = - flip Chunks final <$> traverse (traverse f) chunks -{-# INLINABLE chunkExprs #-} - -- | Remove all `Note` constructors from an `Expr` (i.e. de-`Note`) -- -- This also remove CharacterSet annotations. @@ -233,6 +213,7 @@ denote = \case expression -> Lens.over unsafeSubExpressions denote expression where denoteRecordField (RecordField _ e _ _) = RecordField Nothing (denote e) Nothing Nothing + denoteBinding (Binding _ c _ d _ e) = Binding Nothing c Nothing (fmap denoteBindingAnnotation d) Nothing (denote e) @@ -326,96 +307,6 @@ reservedIdentifiers = reservedKeywords <> , "Sort" ] --- | Same as @Data.Text.splitOn@, except always returning a `NonEmpty` result -splitOn :: Text -> Text -> NonEmpty Text -splitOn needle haystack = - case Data.Text.splitOn needle haystack of - [] -> "" :| [] - t : ts -> t :| ts - --- | Split `Chunks` by lines -linesLiteral :: Chunks s a -> NonEmpty (Chunks s a) -linesLiteral (Chunks [] suffix) = - fmap (Chunks []) (splitOn "\n" suffix) -linesLiteral (Chunks ((prefix, interpolation) : pairs₀) suffix₀) = - foldr - NonEmpty.cons - (Chunks ((lastLine, interpolation) : pairs₁) suffix₁ :| chunks) - (fmap (Chunks []) initLines) - where - splitLines = splitOn "\n" prefix - - initLines = NonEmpty.init splitLines - lastLine = NonEmpty.last splitLines - - Chunks pairs₁ suffix₁ :| chunks = linesLiteral (Chunks pairs₀ suffix₀) - --- | Flatten several `Chunks` back into a single `Chunks` by inserting newlines -unlinesLiteral :: NonEmpty (Chunks s a) -> Chunks s a -unlinesLiteral chunks = - Data.Foldable.fold (NonEmpty.intersperse "\n" chunks) - --- | Returns `True` if the `Chunks` represents a blank line -emptyLine :: Chunks s a -> Bool -emptyLine (Chunks [] "" ) = True -emptyLine (Chunks [] "\r") = True -- So that `\r\n` is treated as a blank line -emptyLine _ = False - --- | Return the leading whitespace for a `Chunks` literal -leadingSpaces :: Chunks s a -> Text -leadingSpaces chunks = Data.Text.takeWhile isSpace firstText - where - isSpace c = c == ' ' || c == '\t' - - firstText = - case chunks of - Chunks [] suffix -> suffix - Chunks ((prefix, _) : _ ) _ -> prefix - -{-| Compute the longest shared whitespace prefix for the purposes of stripping - leading indentation --} -longestSharedWhitespacePrefix :: NonEmpty (Chunks s a) -> Text -longestSharedWhitespacePrefix literals = - case fmap leadingSpaces filteredLines of - l : ls -> Data.Foldable.foldl' sharedPrefix l ls - [] -> "" - where - sharedPrefix ab ac = - case Data.Text.commonPrefixes ab ac of - Just (a, _b, _c) -> a - Nothing -> "" - - -- The standard specifies to filter out blank lines for all lines *except* - -- for the last line - filteredLines = newInit <> pure oldLast - where - oldInit = NonEmpty.init literals - - oldLast = NonEmpty.last literals - - newInit = filter (not . emptyLine) oldInit - --- | Drop the first @n@ characters for a `Chunks` literal -dropLiteral :: Int -> Chunks s a -> Chunks s a -dropLiteral n (Chunks [] suffix) = - Chunks [] (Data.Text.drop n suffix) -dropLiteral n (Chunks ((prefix, interpolation) : rest) suffix) = - Chunks ((Data.Text.drop n prefix, interpolation) : rest) suffix - -{-| Convert a single-quoted `Chunks` literal to the equivalent double-quoted - `Chunks` literal --} -toDoubleQuoted :: Chunks Src a -> Chunks Src a -toDoubleQuoted literal = - unlinesLiteral (fmap (dropLiteral indent) literals) - where - literals = linesLiteral literal - - longestSharedPrefix = longestSharedWhitespacePrefix literals - - indent = Data.Text.length longestSharedPrefix - {-| `shift` is used by both normalization and type-checking to avoid variable capture by shifting variable indices diff --git a/dhall/src/Dhall/Syntax/Types.hs b/dhall/src/Dhall/Syntax/Types.hs index 1a6ebf07e..5e01e83c5 100644 --- a/dhall/src/Dhall/Syntax/Types.hs +++ b/dhall/src/Dhall/Syntax/Types.hs @@ -6,7 +6,6 @@ module Dhall.Syntax.Types ( -- * 'Expr' CharacterSet(..) - , Chunks(..) , DhallDouble(..) , PreferAnnotation(..) , RecordField(..) @@ -18,7 +17,6 @@ module Dhall.Syntax.Types ( , WithComponent(..) ) where -import Data.String (IsString (..)) import Data.Text (Text) import {-# SOURCE #-} Dhall.Pretty.Internal (CharacterSet (..)) import Dhall.Syntax.Expr (Expr (..)) @@ -32,13 +30,6 @@ import GHC.Generics (Generic) newtype DhallDouble = DhallDouble { getDhallDouble :: Double } deriving Generic --- | The body of an interpolated @Text@ literal -data Chunks s a = Chunks [(Text, Expr s a)] Text - deriving Generic - -instance IsString (Chunks s a) where - fromString str = Chunks [] (fromString str) - -- | Used to record the origin of a @//@ operator (i.e. from source code or a -- product of desugaring) data PreferAnnotation s a diff --git a/dhall/src/Dhall/Syntax/Types.hs-boot b/dhall/src/Dhall/Syntax/Types.hs-boot index 4e4320048..267e74bbf 100644 --- a/dhall/src/Dhall/Syntax/Types.hs-boot +++ b/dhall/src/Dhall/Syntax/Types.hs-boot @@ -2,8 +2,6 @@ module Dhall.Syntax.Types where data DhallDouble -data Chunks s a - data PreferAnnotation s a data RecordField s a From e66a91fd51eee72886719302a6ed9f17f1b89876 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 16 Sep 2022 13:02:28 +0200 Subject: [PATCH 06/13] Removed superfluous PreferFromWith data constructor --- dhall/src/Dhall/Syntax/Expr.hs | 7 ++----- dhall/src/Dhall/Syntax/Instances/Bifunctor.hs | 7 ------- dhall/src/Dhall/Syntax/Instances/Data.hs | 2 +- dhall/src/Dhall/Syntax/Instances/Eq.hs | 2 +- dhall/src/Dhall/Syntax/Instances/Foldable.hs | 1 - dhall/src/Dhall/Syntax/Instances/Functor.hs | 1 - dhall/src/Dhall/Syntax/Instances/Lift.hs | 2 +- dhall/src/Dhall/Syntax/Instances/NFData.hs | 2 +- dhall/src/Dhall/Syntax/Instances/Ord.hs | 2 +- dhall/src/Dhall/Syntax/Instances/Show.hs | 2 +- dhall/src/Dhall/Syntax/Instances/Traversable.hs | 1 - dhall/src/Dhall/Syntax/Operations.hs | 7 +------ dhall/src/Dhall/Syntax/Types.hs | 4 +--- dhall/src/Dhall/Syntax/Types.hs-boot | 2 +- dhall/src/Dhall/TypeCheck.hs | 12 ++++-------- dhall/tests/Dhall/Test/QuickCheck.hs | 16 +++++++--------- 16 files changed, 22 insertions(+), 48 deletions(-) diff --git a/dhall/src/Dhall/Syntax/Expr.hs b/dhall/src/Dhall/Syntax/Expr.hs index ee1aa385c..25fc993f2 100644 --- a/dhall/src/Dhall/Syntax/Expr.hs +++ b/dhall/src/Dhall/Syntax/Expr.hs @@ -217,11 +217,8 @@ data Expr s a | Combine (Maybe CharacterSet) (Maybe Text) (Expr s a) (Expr s a) -- | > CombineTypes _ x y ~ x ⩓ y | CombineTypes (Maybe CharacterSet) (Expr s a) (Expr s a) - -- | > Prefer _ False x y ~ x ⫽ y - -- - -- The first field is a `True` when the `Prefer` operator is introduced as a - -- result of desugaring a @with@ expression - | Prefer (Maybe CharacterSet) (PreferAnnotation s a) (Expr s a) (Expr s a) + -- | > Prefer _ _ x y ~ x ⫽ y + | Prefer (Maybe CharacterSet) PreferAnnotation (Expr s a) (Expr s a) -- | > RecordCompletion x y ~ x::y | RecordCompletion (Expr s a) (Expr s a) -- | > Merge x y (Just t ) ~ merge x y : t diff --git a/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs b/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs index fbd4fee75..5446efa0f 100644 --- a/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs +++ b/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs @@ -19,13 +19,6 @@ instance Bifunctor Binding where second = fmap -instance Bifunctor PreferAnnotation where - first _ PreferFromSource = PreferFromSource - first f (PreferFromWith e ) = PreferFromWith (first f e) - first _ PreferFromCompletion = PreferFromCompletion - - second = fmap - instance Bifunctor RecordField where first k (RecordField s0 value' s1 s2) = RecordField (k <$> s0) (first k value') (k <$> s1) (k <$> s2) diff --git a/dhall/src/Dhall/Syntax/Instances/Data.hs b/dhall/src/Dhall/Syntax/Instances/Data.hs index 717366b4e..29f34792b 100644 --- a/dhall/src/Dhall/Syntax/Instances/Data.hs +++ b/dhall/src/Dhall/Syntax/Instances/Data.hs @@ -18,7 +18,7 @@ deriving instance Data Var deriving instance (Data a, Data s) => Data (Binding s a) deriving instance Data DhallDouble deriving instance (Data a, Data s) => Data (Chunks s a) -deriving instance (Data a, Data s) => Data (PreferAnnotation s a) +deriving instance Data PreferAnnotation deriving instance (Data a, Data s) => Data (RecordField s a) deriving instance (Data a, Data s) => Data (FunctionBinding s a) deriving instance Data s => Data (FieldSelection s) diff --git a/dhall/src/Dhall/Syntax/Instances/Eq.hs b/dhall/src/Dhall/Syntax/Instances/Eq.hs index 8b02f0bda..658da0cba 100644 --- a/dhall/src/Dhall/Syntax/Instances/Eq.hs +++ b/dhall/src/Dhall/Syntax/Instances/Eq.hs @@ -17,7 +17,7 @@ deriving instance Eq Const deriving instance Eq Var deriving instance (Eq s, Eq a) => Eq (Binding s a) deriving instance (Eq s, Eq a) => Eq (Chunks s a) -deriving instance (Eq s, Eq a) => Eq (PreferAnnotation s a) +deriving instance Eq PreferAnnotation deriving instance (Eq s, Eq a) => Eq (RecordField s a) deriving instance (Eq s, Eq a) => Eq (FunctionBinding s a) deriving instance Eq s => Eq (FieldSelection s) diff --git a/dhall/src/Dhall/Syntax/Instances/Foldable.hs b/dhall/src/Dhall/Syntax/Instances/Foldable.hs index 02cbec863..399b90b5f 100644 --- a/dhall/src/Dhall/Syntax/Instances/Foldable.hs +++ b/dhall/src/Dhall/Syntax/Instances/Foldable.hs @@ -12,7 +12,6 @@ import Dhall.Syntax.Types deriving instance Foldable (Binding s) deriving instance Foldable (Chunks s) -deriving instance Foldable (PreferAnnotation s) deriving instance Foldable (RecordField s) deriving instance Foldable (FunctionBinding s) deriving instance Foldable FieldSelection diff --git a/dhall/src/Dhall/Syntax/Instances/Functor.hs b/dhall/src/Dhall/Syntax/Instances/Functor.hs index b11c5f8fa..1a3b1e1cc 100644 --- a/dhall/src/Dhall/Syntax/Instances/Functor.hs +++ b/dhall/src/Dhall/Syntax/Instances/Functor.hs @@ -15,7 +15,6 @@ import qualified Lens.Family as Lens deriving instance Functor (Binding s) deriving instance Functor (Chunks s) -deriving instance Functor (PreferAnnotation s) deriving instance Functor (RecordField s) deriving instance Functor (FunctionBinding s) deriving instance Functor FieldSelection diff --git a/dhall/src/Dhall/Syntax/Instances/Lift.hs b/dhall/src/Dhall/Syntax/Instances/Lift.hs index d09fdd203..38547c7fa 100644 --- a/dhall/src/Dhall/Syntax/Instances/Lift.hs +++ b/dhall/src/Dhall/Syntax/Instances/Lift.hs @@ -25,7 +25,7 @@ deriving instance Lift Var deriving instance (Lift s, Lift a) => Lift (Binding s a) deriving instance Lift DhallDouble deriving instance (Lift s, Lift a) => Lift (Chunks s a) -deriving instance (Lift s, Lift a) => Lift (PreferAnnotation s a) +deriving instance Lift PreferAnnotation deriving instance (Lift s, Lift a) => Lift (RecordField s a) deriving instance (Lift s, Lift a) => Lift (FunctionBinding s a) deriving instance Lift s => Lift (FieldSelection s) diff --git a/dhall/src/Dhall/Syntax/Instances/NFData.hs b/dhall/src/Dhall/Syntax/Instances/NFData.hs index a718905e7..2740abe38 100644 --- a/dhall/src/Dhall/Syntax/Instances/NFData.hs +++ b/dhall/src/Dhall/Syntax/Instances/NFData.hs @@ -16,7 +16,7 @@ instance NFData Var instance (NFData s, NFData a) => NFData (Binding s a) instance NFData DhallDouble instance (NFData s, NFData a) => NFData (Chunks s a) -instance (NFData s, NFData a) => NFData (PreferAnnotation s a) +instance NFData PreferAnnotation instance (NFData s, NFData a) => NFData (RecordField s a) instance (NFData s, NFData a) => NFData (FunctionBinding s a) instance NFData s => NFData (FieldSelection s) diff --git a/dhall/src/Dhall/Syntax/Instances/Ord.hs b/dhall/src/Dhall/Syntax/Instances/Ord.hs index a700e53c8..02a7541cc 100644 --- a/dhall/src/Dhall/Syntax/Instances/Ord.hs +++ b/dhall/src/Dhall/Syntax/Instances/Ord.hs @@ -17,7 +17,7 @@ deriving instance Ord Const deriving instance Ord Var deriving instance (Ord s, Ord a) => Ord (Binding s a) deriving instance (Ord s, Ord a) => Ord (Chunks s a) -deriving instance (Ord s, Ord a) => Ord (PreferAnnotation s a) +deriving instance Ord PreferAnnotation deriving instance (Ord s, Ord a) => Ord (RecordField s a) deriving instance (Ord s, Ord a) => Ord (FunctionBinding s a) deriving instance Ord s => Ord (FieldSelection s) diff --git a/dhall/src/Dhall/Syntax/Instances/Show.hs b/dhall/src/Dhall/Syntax/Instances/Show.hs index 0b3cd3635..d4dc1b36d 100644 --- a/dhall/src/Dhall/Syntax/Instances/Show.hs +++ b/dhall/src/Dhall/Syntax/Instances/Show.hs @@ -17,7 +17,7 @@ deriving instance Show Var deriving instance (Show s, Show a) => Show (Binding s a) deriving instance Show DhallDouble deriving instance (Show s, Show a) => Show (Chunks s a) -deriving instance (Show s, Show a) => Show (PreferAnnotation s a) +deriving instance Show PreferAnnotation deriving instance (Show s, Show a) => Show (RecordField s a) deriving instance (Show s, Show a) => Show (FunctionBinding s a) deriving instance Show s => Show (FieldSelection s) diff --git a/dhall/src/Dhall/Syntax/Instances/Traversable.hs b/dhall/src/Dhall/Syntax/Instances/Traversable.hs index db0f4c8bb..982534fe6 100644 --- a/dhall/src/Dhall/Syntax/Instances/Traversable.hs +++ b/dhall/src/Dhall/Syntax/Instances/Traversable.hs @@ -14,7 +14,6 @@ import Dhall.Syntax.Types deriving instance Traversable (Binding s) deriving instance Traversable (Chunks s) -deriving instance Traversable (PreferAnnotation s) deriving instance Traversable (RecordField s) deriving instance Traversable (FunctionBinding s) deriving instance Traversable FieldSelection diff --git a/dhall/src/Dhall/Syntax/Operations.hs b/dhall/src/Dhall/Syntax/Operations.hs index faeec990f..74c4ae799 100644 --- a/dhall/src/Dhall/Syntax/Operations.hs +++ b/dhall/src/Dhall/Syntax/Operations.hs @@ -132,12 +132,7 @@ unsafeSubExpressions _ None = pure None unsafeSubExpressions f (Union a) = Union <$> traverse (traverse f) a unsafeSubExpressions f (Combine cs a b c) = Combine cs a <$> f b <*> f c unsafeSubExpressions f (CombineTypes cs a b) = CombineTypes cs <$> f a <*> f b -unsafeSubExpressions f (Prefer cs a b c) = Prefer cs <$> a' <*> f b <*> f c - where - a' = case a of - PreferFromSource -> pure PreferFromSource - PreferFromWith d -> PreferFromWith <$> f d - PreferFromCompletion -> pure PreferFromCompletion +unsafeSubExpressions f (Prefer cs a b c) = Prefer cs <$> pure a <*> f b <*> f c unsafeSubExpressions f (RecordCompletion a b) = RecordCompletion <$> f a <*> f b unsafeSubExpressions f (Merge a b t) = Merge <$> f a <*> f b <*> traverse f t unsafeSubExpressions f (ToMap a t) = ToMap <$> f a <*> traverse f t diff --git a/dhall/src/Dhall/Syntax/Types.hs b/dhall/src/Dhall/Syntax/Types.hs index 5e01e83c5..152997bce 100644 --- a/dhall/src/Dhall/Syntax/Types.hs +++ b/dhall/src/Dhall/Syntax/Types.hs @@ -32,10 +32,8 @@ newtype DhallDouble = DhallDouble { getDhallDouble :: Double } -- | Used to record the origin of a @//@ operator (i.e. from source code or a -- product of desugaring) -data PreferAnnotation s a +data PreferAnnotation = PreferFromSource - | PreferFromWith (Expr s a) - -- ^ Stores the original @with@ expression | PreferFromCompletion deriving Generic diff --git a/dhall/src/Dhall/Syntax/Types.hs-boot b/dhall/src/Dhall/Syntax/Types.hs-boot index 267e74bbf..d174d141c 100644 --- a/dhall/src/Dhall/Syntax/Types.hs-boot +++ b/dhall/src/Dhall/Syntax/Types.hs-boot @@ -2,7 +2,7 @@ module Dhall.Syntax.Types where data DhallDouble -data PreferAnnotation s a +data PreferAnnotation data RecordField s a diff --git a/dhall/src/Dhall/TypeCheck.hs b/dhall/src/Dhall/TypeCheck.hs index 82667d1bf..e6d63257f 100644 --- a/dhall/src/Dhall/TypeCheck.hs +++ b/dhall/src/Dhall/TypeCheck.hs @@ -880,7 +880,7 @@ infer typer = loop return (VConst c) - Prefer _ a l r -> do + Prefer _ _ l r -> do _L' <- loop ctx l _R' <- loop ctx r @@ -893,11 +893,7 @@ infer typer = loop let l'' = quote names (eval values l) - case a of - PreferFromWith withExpression -> - die (MustUpdateARecord withExpression l'' _L'') - _ -> - die (MustCombineARecord '⫽' l'' _L'') + die (MustCombineARecord '⫽' l'' _L'') xRs' <- case _R' of VRecord xRs' -> return xRs' @@ -1475,7 +1471,7 @@ prettyTypeMessage (UnboundVariable x) = ErrorMessages {..} -- https://github.com/dhall-lang/dhall-haskell/pull/116 where short = "Unbound variable: " <> Pretty.pretty x - + hints = [] long = @@ -1590,7 +1586,7 @@ prettyTypeMessage (UnboundVariable x) = ErrorMessages {..} prettyTypeMessage (InvalidInputType expr) = ErrorMessages {..} where short = "Invalid function input" - + hints = [] long = diff --git a/dhall/tests/Dhall/Test/QuickCheck.hs b/dhall/tests/Dhall/Test/QuickCheck.hs index cc4aeacfc..42c814f01 100644 --- a/dhall/tests/Dhall/Test/QuickCheck.hs +++ b/dhall/tests/Dhall/Test/QuickCheck.hs @@ -274,13 +274,13 @@ instance Arbitrary Directory where shrink = genericShrink -instance (Arbitrary s, Arbitrary a) => Arbitrary (PreferAnnotation s a) where - arbitrary = - Test.QuickCheck.oneof - [ pure PreferFromSource - , PreferFromWith <$> arbitrary - , pure PreferFromCompletion - ] +instance Arbitrary PreferAnnotation where + arbitrary = Test.QuickCheck.oneof + [ pure PreferFromSource + , pure PreferFromCompletion + ] + + shrink = genericShrink instance (Arbitrary s, Arbitrary a) => Arbitrary (RecordField s a) where arbitrary = lift4 RecordField @@ -438,8 +438,6 @@ standardizedExpression With{} = False standardizedExpression (Prefer _ PreferFromCompletion _ _) = False -standardizedExpression (Prefer _ (PreferFromWith _) _ _) = - False -- The following three expressions are valid ASTs, but they can never be parsed, -- because the annotation will associate with `Merge`/`ListLit`/`ToMap` with -- higher precedence From 808e1183642a5e33f13d2f6648bfe031f51c0efe Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 16 Sep 2022 13:27:32 +0200 Subject: [PATCH 07/13] Moved RecordField to Dhall.Syntax.RecordField --- dhall/dhall.cabal | 3 +- dhall/src/Dhall/Syntax.hs | 1 + dhall/src/Dhall/Syntax/Expr.hs | 19 ++-- .../src/Dhall/Syntax/Instances/Applicative.hs | 1 + dhall/src/Dhall/Syntax/Instances/Bifunctor.hs | 1 + dhall/src/Dhall/Syntax/Instances/Data.hs | 3 +- dhall/src/Dhall/Syntax/Instances/Eq.hs | 3 +- dhall/src/Dhall/Syntax/Instances/Foldable.hs | 1 + dhall/src/Dhall/Syntax/Instances/Functor.hs | 3 +- dhall/src/Dhall/Syntax/Instances/Lift.hs | 1 + dhall/src/Dhall/Syntax/Instances/NFData.hs | 3 +- dhall/src/Dhall/Syntax/Instances/Ord.hs | 1 + dhall/src/Dhall/Syntax/Instances/Show.hs | 1 + .../src/Dhall/Syntax/Instances/Traversable.hs | 1 + dhall/src/Dhall/Syntax/Operations.hs | 31 ++---- dhall/src/Dhall/Syntax/RecordField.hs | 96 +++++++++++++++++++ dhall/src/Dhall/Syntax/Types.hs | 69 ------------- dhall/src/Dhall/Syntax/Types.hs-boot | 2 - 18 files changed, 131 insertions(+), 109 deletions(-) create mode 100644 dhall/src/Dhall/Syntax/RecordField.hs diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index b9d8ade93..1e4cc5f66 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -373,15 +373,14 @@ Library Dhall.Syntax.Instances.Functor Dhall.Syntax.Instances.Lift Dhall.Syntax.Instances.Monad - -- Dhall.Syntax.Instances.Monoid Dhall.Syntax.Instances.NFData Dhall.Syntax.Instances.Ord Dhall.Syntax.Instances.Pretty - --Dhall.Syntax.Instances.Semigroup Dhall.Syntax.Instances.Show Dhall.Syntax.Instances.Traversable Dhall.Syntax.MultiLet Dhall.Syntax.Operations + Dhall.Syntax.RecordField Dhall.Syntax.Types Dhall.Syntax.Var Dhall.URL diff --git a/dhall/src/Dhall/Syntax.hs b/dhall/src/Dhall/Syntax.hs index ceb704af8..c97c603fe 100644 --- a/dhall/src/Dhall/Syntax.hs +++ b/dhall/src/Dhall/Syntax.hs @@ -22,5 +22,6 @@ import Dhall.Syntax.Instances.Show as Export () import Dhall.Syntax.Instances.Traversable as Export () import Dhall.Syntax.MultiLet as Export import Dhall.Syntax.Operations as Export +import Dhall.Syntax.RecordField as Export import Dhall.Syntax.Types as Export import Dhall.Syntax.Var as Export diff --git a/dhall/src/Dhall/Syntax/Expr.hs b/dhall/src/Dhall/Syntax/Expr.hs index 25fc993f2..c8e96e711 100644 --- a/dhall/src/Dhall/Syntax/Expr.hs +++ b/dhall/src/Dhall/Syntax/Expr.hs @@ -10,20 +10,21 @@ module Dhall.Syntax.Expr ( Expr(..) ) where -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Sequence (Seq) -import Data.String (IsString (..)) -import Data.Text (Text) -import Data.Traversable () -import Dhall.Map (Map) -import {-# SOURCE #-} Dhall.Pretty.Internal (CharacterSet (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Sequence (Seq) +import Data.String (IsString (..)) +import Data.Text (Text) +import Data.Traversable () +import Dhall.Map (Map) +import {-# SOURCE #-} Dhall.Pretty.Internal (CharacterSet (..)) import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Const +import Dhall.Syntax.RecordField import {-# SOURCE #-} Dhall.Syntax.Types import Dhall.Syntax.Var -import GHC.Generics (Generic) -import Numeric.Natural (Natural) +import GHC.Generics (Generic) +import Numeric.Natural (Natural) import qualified Data.Time as Time diff --git a/dhall/src/Dhall/Syntax/Instances/Applicative.hs b/dhall/src/Dhall/Syntax/Instances/Applicative.hs index 445d86b55..169cbd9e0 100644 --- a/dhall/src/Dhall/Syntax/Instances/Applicative.hs +++ b/dhall/src/Dhall/Syntax/Instances/Applicative.hs @@ -6,6 +6,7 @@ import Dhall.Syntax.Binding import Dhall.Syntax.Expr import Dhall.Syntax.Instances.Functor () import Dhall.Syntax.Operations +import Dhall.Syntax.RecordField import Dhall.Syntax.Types import qualified Lens.Family as Lens diff --git a/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs b/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs index 5446efa0f..9c5555ba5 100644 --- a/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs +++ b/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs @@ -7,6 +7,7 @@ import Dhall.Syntax.Binding import Dhall.Syntax.Expr import Dhall.Syntax.Instances.Functor () import Dhall.Syntax.Operations +import Dhall.Syntax.RecordField import Dhall.Syntax.Types import qualified Lens.Family as Lens diff --git a/dhall/src/Dhall/Syntax/Instances/Data.hs b/dhall/src/Dhall/Syntax/Instances/Data.hs index 29f34792b..7a620743f 100644 --- a/dhall/src/Dhall/Syntax/Instances/Data.hs +++ b/dhall/src/Dhall/Syntax/Instances/Data.hs @@ -5,11 +5,12 @@ module Dhall.Syntax.Instances.Data () where -import Data.Data (Data) +import Data.Data (Data) import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr +import Dhall.Syntax.RecordField import Dhall.Syntax.Types import Dhall.Syntax.Var diff --git a/dhall/src/Dhall/Syntax/Instances/Eq.hs b/dhall/src/Dhall/Syntax/Instances/Eq.hs index 658da0cba..99e8f9de8 100644 --- a/dhall/src/Dhall/Syntax/Instances/Eq.hs +++ b/dhall/src/Dhall/Syntax/Instances/Eq.hs @@ -4,12 +4,13 @@ module Dhall.Syntax.Instances.Eq () where -import Data.Bits (xor) +import Data.Bits (xor) import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr import Dhall.Syntax.Import +import Dhall.Syntax.RecordField import Dhall.Syntax.Types import Dhall.Syntax.Var diff --git a/dhall/src/Dhall/Syntax/Instances/Foldable.hs b/dhall/src/Dhall/Syntax/Instances/Foldable.hs index 399b90b5f..beae1e36c 100644 --- a/dhall/src/Dhall/Syntax/Instances/Foldable.hs +++ b/dhall/src/Dhall/Syntax/Instances/Foldable.hs @@ -8,6 +8,7 @@ module Dhall.Syntax.Instances.Foldable () where import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Expr +import Dhall.Syntax.RecordField import Dhall.Syntax.Types deriving instance Foldable (Binding s) diff --git a/dhall/src/Dhall/Syntax/Instances/Functor.hs b/dhall/src/Dhall/Syntax/Instances/Functor.hs index 1a3b1e1cc..c66a6d44b 100644 --- a/dhall/src/Dhall/Syntax/Instances/Functor.hs +++ b/dhall/src/Dhall/Syntax/Instances/Functor.hs @@ -8,7 +8,8 @@ module Dhall.Syntax.Instances.Functor () where import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Expr -import {-# SOURCE #-} Dhall.Syntax.Operations (unsafeSubExpressions) +import {-# SOURCE #-} Dhall.Syntax.Operations (unsafeSubExpressions) +import Dhall.Syntax.RecordField import Dhall.Syntax.Types import qualified Lens.Family as Lens diff --git a/dhall/src/Dhall/Syntax/Instances/Lift.hs b/dhall/src/Dhall/Syntax/Instances/Lift.hs index 38547c7fa..b4bcecde8 100644 --- a/dhall/src/Dhall/Syntax/Instances/Lift.hs +++ b/dhall/src/Dhall/Syntax/Instances/Lift.hs @@ -9,6 +9,7 @@ import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr +import Dhall.Syntax.RecordField import Dhall.Syntax.Types import Dhall.Syntax.Var import Language.Haskell.TH.Syntax (Lift) diff --git a/dhall/src/Dhall/Syntax/Instances/NFData.hs b/dhall/src/Dhall/Syntax/Instances/NFData.hs index 2740abe38..2d6b99786 100644 --- a/dhall/src/Dhall/Syntax/Instances/NFData.hs +++ b/dhall/src/Dhall/Syntax/Instances/NFData.hs @@ -2,12 +2,13 @@ module Dhall.Syntax.Instances.NFData () where -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData) import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr import Dhall.Syntax.Import +import Dhall.Syntax.RecordField import Dhall.Syntax.Types import Dhall.Syntax.Var diff --git a/dhall/src/Dhall/Syntax/Instances/Ord.hs b/dhall/src/Dhall/Syntax/Instances/Ord.hs index 02a7541cc..83cc92dc0 100644 --- a/dhall/src/Dhall/Syntax/Instances/Ord.hs +++ b/dhall/src/Dhall/Syntax/Instances/Ord.hs @@ -10,6 +10,7 @@ import Dhall.Syntax.Const import Dhall.Syntax.Expr import Dhall.Syntax.Import import Dhall.Syntax.Instances.Eq () +import Dhall.Syntax.RecordField import Dhall.Syntax.Types import Dhall.Syntax.Var diff --git a/dhall/src/Dhall/Syntax/Instances/Show.hs b/dhall/src/Dhall/Syntax/Instances/Show.hs index d4dc1b36d..25b94334d 100644 --- a/dhall/src/Dhall/Syntax/Instances/Show.hs +++ b/dhall/src/Dhall/Syntax/Instances/Show.hs @@ -9,6 +9,7 @@ import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr import Dhall.Syntax.Import +import Dhall.Syntax.RecordField import Dhall.Syntax.Types import Dhall.Syntax.Var diff --git a/dhall/src/Dhall/Syntax/Instances/Traversable.hs b/dhall/src/Dhall/Syntax/Instances/Traversable.hs index 982534fe6..754d9c6f3 100644 --- a/dhall/src/Dhall/Syntax/Instances/Traversable.hs +++ b/dhall/src/Dhall/Syntax/Instances/Traversable.hs @@ -10,6 +10,7 @@ import Dhall.Syntax.Chunks import Dhall.Syntax.Expr import Dhall.Syntax.Instances.Foldable () import Dhall.Syntax.Instances.Functor () +import Dhall.Syntax.RecordField import Dhall.Syntax.Types deriving instance Traversable (Binding s) diff --git a/dhall/src/Dhall/Syntax/Operations.hs b/dhall/src/Dhall/Syntax/Operations.hs index 74c4ae799..4a5e41673 100644 --- a/dhall/src/Dhall/Syntax/Operations.hs +++ b/dhall/src/Dhall/Syntax/Operations.hs @@ -7,7 +7,6 @@ module Dhall.Syntax.Operations ( subExpressions , subExpressionsWith , unsafeSubExpressions - , recordFieldExprs , functionBindingExprs -- ** Handling 'Note's @@ -26,15 +25,16 @@ module Dhall.Syntax.Operations ( , shift ) where -import Data.HashSet (HashSet) -import Data.Text (Text) -import Data.Void (Void) -import Dhall.Syntax.Binding (Binding (..), bindingExprs) -import Dhall.Syntax.Chunks (chunkExprs) +import Data.HashSet (HashSet) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Syntax.Binding (Binding (..), bindingExprs) +import Dhall.Syntax.Chunks (chunkExprs) import Dhall.Syntax.Expr +import Dhall.Syntax.RecordField (RecordField (..), recordFieldExprs) import Dhall.Syntax.Types import Dhall.Syntax.Var -import Unsafe.Coerce (unsafeCoerce) +import Unsafe.Coerce (unsafeCoerce) import qualified Data.HashSet import qualified Data.Text @@ -105,8 +105,7 @@ unsafeSubExpressions _ Double = pure Double unsafeSubExpressions _ (DoubleLit n) = pure (DoubleLit n) unsafeSubExpressions _ DoubleShow = pure DoubleShow unsafeSubExpressions _ Text = pure Text -unsafeSubExpressions f (TextLit chunks) = - TextLit <$> chunkExprs f chunks +unsafeSubExpressions f (TextLit chunks) = TextLit <$> chunkExprs f chunks unsafeSubExpressions f (TextAppend a b) = TextAppend <$> f a <*> f b unsafeSubExpressions _ TextReplace = pure TextReplace unsafeSubExpressions _ TextShow = pure TextShow @@ -159,20 +158,6 @@ unhandledConstructor constructor = <> " construtor" ) -{-| Traverse over the immediate 'Expr' children in a 'RecordField'. --} -recordFieldExprs - :: Applicative f - => (Expr s a -> f (Expr s b)) - -> RecordField s a -> f (RecordField s b) -recordFieldExprs f (RecordField s0 e s1 s2) = - RecordField - <$> pure s0 - <*> f e - <*> pure s1 - <*> pure s2 -{-# INLINABLE recordFieldExprs #-} - {-| Traverse over the immediate 'Expr' children in a 'FunctionBinding'. -} functionBindingExprs diff --git a/dhall/src/Dhall/Syntax/RecordField.hs b/dhall/src/Dhall/Syntax/RecordField.hs new file mode 100644 index 000000000..9df39f05c --- /dev/null +++ b/dhall/src/Dhall/Syntax/RecordField.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DeriveGeneric #-} + +{-| This module contains the core syntax types. +-} + +module Dhall.Syntax.RecordField ( + RecordField(..) + , makeRecordField + + -- * Optics + , recordFieldExprs + ) where + +import {-# SOURCE #-} Dhall.Syntax.Expr (Expr) +import GHC.Generics (Generic) + +-- | Record the field of a record-type and record-literal expression. +-- The reason why we use the same ADT for both of them is because they store +-- the same information. +-- +-- For example, +-- +-- > { {- A -} x {- B -} : {- C -} T } +-- +-- ... or +-- +-- > { {- A -} x {- B -} = {- C -} T } +-- +-- will be instantiated as follows: +-- +-- * @recordFieldSrc0@ corresponds to the @A@ comment. +-- * @recordFieldValue@ is @"T"@ +-- * @recordFieldSrc1@ corresponds to the @B@ comment. +-- * @recordFieldSrc2@ corresponds to the @C@ comment. +-- +-- Although the @A@ comment isn't annotating the @"T"@ Record Field, +-- this is the best place to keep these comments. +-- +-- Note that @recordFieldSrc2@ is always 'Nothing' when the 'RecordField' is for +-- a punned entry, because there is no @=@ sign. For example, +-- +-- > { {- A -} x {- B -} } +-- +-- will be instantiated as follows: +-- +-- * @recordFieldSrc0@ corresponds to the @A@ comment. +-- * @recordFieldValue@ corresponds to @(Var "x")@ +-- * @recordFieldSrc1@ corresponds to the @B@ comment. +-- * @recordFieldSrc2@ will be 'Nothing' +-- +-- The labels involved in a record using dot-syntax like in this example: +-- +-- > { {- A -} a {- B -} . {- C -} b {- D -} . {- E -} c {- F -} = {- G -} e } +-- +-- will be instantiated as follows: +-- +-- * For both the @a@ and @b@ field, @recordfieldSrc2@ is 'Nothing' +-- * For the @a@ field: +-- * @recordFieldSrc0@ corresponds to the @A@ comment +-- * @recordFieldSrc1@ corresponds to the @B@ comment +-- * For the @b@ field: +-- * @recordFieldSrc0@ corresponds to the @C@ comment +-- * @recordFieldSrc1@ corresponds to the @D@ comment +-- * For the @c@ field: +-- * @recordFieldSrc0@ corresponds to the @E@ comment +-- * @recordFieldSrc1@ corresponds to the @F@ comment +-- * @recordFieldSrc2@ corresponds to the @G@ comment +-- +-- That is, for every label except the last one the semantics of +-- @recordFieldSrc0@ and @recordFieldSrc1@ are the same from a regular record +-- label but @recordFieldSrc2@ is always 'Nothing'. For the last keyword, all +-- srcs are 'Just' +data RecordField s a = RecordField + { recordFieldSrc0 :: Maybe s + , recordFieldValue :: Expr s a + , recordFieldSrc1 :: Maybe s + , recordFieldSrc2 :: Maybe s + } deriving Generic + +-- | Construct a 'RecordField' with no src information +makeRecordField :: Expr s a -> RecordField s a +makeRecordField e = RecordField Nothing e Nothing Nothing + +{-| Traverse over the immediate 'Expr' children in a 'RecordField'. +-} +recordFieldExprs + :: Applicative f + => (Expr s a -> f (Expr s b)) + -> RecordField s a -> f (RecordField s b) +recordFieldExprs f (RecordField s0 e s1 s2) = + RecordField + <$> pure s0 + <*> f e + <*> pure s1 + <*> pure s2 +{-# INLINABLE recordFieldExprs #-} diff --git a/dhall/src/Dhall/Syntax/Types.hs b/dhall/src/Dhall/Syntax/Types.hs index 152997bce..ca27c64d1 100644 --- a/dhall/src/Dhall/Syntax/Types.hs +++ b/dhall/src/Dhall/Syntax/Types.hs @@ -8,8 +8,6 @@ module Dhall.Syntax.Types ( CharacterSet(..) , DhallDouble(..) , PreferAnnotation(..) - , RecordField(..) - , makeRecordField , FunctionBinding(..) , makeFunctionBinding , FieldSelection(..) @@ -37,73 +35,6 @@ data PreferAnnotation | PreferFromCompletion deriving Generic --- | Record the field of a record-type and record-literal expression. --- The reason why we use the same ADT for both of them is because they store --- the same information. --- --- For example, --- --- > { {- A -} x {- B -} : {- C -} T } --- --- ... or --- --- > { {- A -} x {- B -} = {- C -} T } --- --- will be instantiated as follows: --- --- * @recordFieldSrc0@ corresponds to the @A@ comment. --- * @recordFieldValue@ is @"T"@ --- * @recordFieldSrc1@ corresponds to the @B@ comment. --- * @recordFieldSrc2@ corresponds to the @C@ comment. --- --- Although the @A@ comment isn't annotating the @"T"@ Record Field, --- this is the best place to keep these comments. --- --- Note that @recordFieldSrc2@ is always 'Nothing' when the 'RecordField' is for --- a punned entry, because there is no @=@ sign. For example, --- --- > { {- A -} x {- B -} } --- --- will be instantiated as follows: --- --- * @recordFieldSrc0@ corresponds to the @A@ comment. --- * @recordFieldValue@ corresponds to @(Var "x")@ --- * @recordFieldSrc1@ corresponds to the @B@ comment. --- * @recordFieldSrc2@ will be 'Nothing' --- --- The labels involved in a record using dot-syntax like in this example: --- --- > { {- A -} a {- B -} . {- C -} b {- D -} . {- E -} c {- F -} = {- G -} e } --- --- will be instantiated as follows: --- --- * For both the @a@ and @b@ field, @recordfieldSrc2@ is 'Nothing' --- * For the @a@ field: --- * @recordFieldSrc0@ corresponds to the @A@ comment --- * @recordFieldSrc1@ corresponds to the @B@ comment --- * For the @b@ field: --- * @recordFieldSrc0@ corresponds to the @C@ comment --- * @recordFieldSrc1@ corresponds to the @D@ comment --- * For the @c@ field: --- * @recordFieldSrc0@ corresponds to the @E@ comment --- * @recordFieldSrc1@ corresponds to the @F@ comment --- * @recordFieldSrc2@ corresponds to the @G@ comment --- --- That is, for every label except the last one the semantics of --- @recordFieldSrc0@ and @recordFieldSrc1@ are the same from a regular record --- label but @recordFieldSrc2@ is always 'Nothing'. For the last keyword, all --- srcs are 'Just' -data RecordField s a = RecordField - { recordFieldSrc0 :: Maybe s - , recordFieldValue :: Expr s a - , recordFieldSrc1 :: Maybe s - , recordFieldSrc2 :: Maybe s - } deriving Generic - --- | Construct a 'RecordField' with no src information -makeRecordField :: Expr s a -> RecordField s a -makeRecordField e = RecordField Nothing e Nothing Nothing - -- | Record the label of a function or a function-type expression -- -- For example, diff --git a/dhall/src/Dhall/Syntax/Types.hs-boot b/dhall/src/Dhall/Syntax/Types.hs-boot index d174d141c..66d022697 100644 --- a/dhall/src/Dhall/Syntax/Types.hs-boot +++ b/dhall/src/Dhall/Syntax/Types.hs-boot @@ -4,8 +4,6 @@ data DhallDouble data PreferAnnotation -data RecordField s a - data FunctionBinding s a data FieldSelection s From b250e2c43b2037f1837afe0761adea73646b66bf Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 16 Sep 2022 19:52:07 +0200 Subject: [PATCH 08/13] Moved FunctionBinding to Dhall.Syntax.FunctionBinding --- dhall/dhall.cabal | 1 + dhall/src/Dhall/Syntax.hs | 50 +++++++++-------- dhall/src/Dhall/Syntax/Expr.hs | 21 +++---- dhall/src/Dhall/Syntax/FunctionBinding.hs | 56 +++++++++++++++++++ .../src/Dhall/Syntax/Instances/Applicative.hs | 2 +- dhall/src/Dhall/Syntax/Instances/Bifunctor.hs | 2 +- dhall/src/Dhall/Syntax/Instances/Data.hs | 3 +- dhall/src/Dhall/Syntax/Instances/Eq.hs | 3 +- dhall/src/Dhall/Syntax/Instances/Foldable.hs | 1 + dhall/src/Dhall/Syntax/Instances/Functor.hs | 3 +- dhall/src/Dhall/Syntax/Instances/Lift.hs | 3 +- dhall/src/Dhall/Syntax/Instances/NFData.hs | 3 +- dhall/src/Dhall/Syntax/Instances/Ord.hs | 3 +- dhall/src/Dhall/Syntax/Instances/Show.hs | 1 + .../src/Dhall/Syntax/Instances/Traversable.hs | 1 + dhall/src/Dhall/Syntax/Operations.hs | 31 +++------- dhall/src/Dhall/Syntax/Types.hs | 36 +----------- dhall/src/Dhall/Syntax/Types.hs-boot | 2 - 18 files changed, 123 insertions(+), 99 deletions(-) create mode 100644 dhall/src/Dhall/Syntax/FunctionBinding.hs diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index 1e4cc5f66..a594b3f44 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -364,6 +364,7 @@ Library Dhall.Syntax.Chunks Dhall.Syntax.Const Dhall.Syntax.Expr + Dhall.Syntax.FunctionBinding Dhall.Syntax.Import Dhall.Syntax.Instances.Applicative Dhall.Syntax.Instances.Bifunctor diff --git a/dhall/src/Dhall/Syntax.hs b/dhall/src/Dhall/Syntax.hs index c97c603fe..dcdc06b61 100644 --- a/dhall/src/Dhall/Syntax.hs +++ b/dhall/src/Dhall/Syntax.hs @@ -2,26 +2,30 @@ module Dhall.Syntax ( module Export ) where -import Dhall.Syntax.Binding as Export -import Dhall.Syntax.Chunks as Export -import Dhall.Syntax.Const as Export -import Dhall.Syntax.Expr as Export -import Dhall.Syntax.Import as Export -import Dhall.Syntax.Instances.Applicative as Export () -import Dhall.Syntax.Instances.Bifunctor as Export () -import Dhall.Syntax.Instances.Data as Export () -import Dhall.Syntax.Instances.Eq as Export () -import Dhall.Syntax.Instances.Foldable as Export () -import Dhall.Syntax.Instances.Functor as Export () -import Dhall.Syntax.Instances.Lift as Export () -import Dhall.Syntax.Instances.Monad as Export () -import Dhall.Syntax.Instances.NFData as Export () -import Dhall.Syntax.Instances.Ord as Export () -import Dhall.Syntax.Instances.Pretty as Export -import Dhall.Syntax.Instances.Show as Export () -import Dhall.Syntax.Instances.Traversable as Export () -import Dhall.Syntax.MultiLet as Export -import Dhall.Syntax.Operations as Export -import Dhall.Syntax.RecordField as Export -import Dhall.Syntax.Types as Export -import Dhall.Syntax.Var as Export +import {-# SOURCE #-} Dhall.Pretty.Internal as Export + ( CharacterSet (..) + ) +import Dhall.Syntax.Binding as Export +import Dhall.Syntax.Chunks as Export +import Dhall.Syntax.Const as Export +import Dhall.Syntax.Expr as Export +import Dhall.Syntax.FunctionBinding as Export +import Dhall.Syntax.Import as Export +import Dhall.Syntax.Instances.Applicative as Export () +import Dhall.Syntax.Instances.Bifunctor as Export () +import Dhall.Syntax.Instances.Data as Export () +import Dhall.Syntax.Instances.Eq as Export () +import Dhall.Syntax.Instances.Foldable as Export () +import Dhall.Syntax.Instances.Functor as Export () +import Dhall.Syntax.Instances.Lift as Export () +import Dhall.Syntax.Instances.Monad as Export () +import Dhall.Syntax.Instances.NFData as Export () +import Dhall.Syntax.Instances.Ord as Export () +import Dhall.Syntax.Instances.Pretty as Export +import Dhall.Syntax.Instances.Show as Export () +import Dhall.Syntax.Instances.Traversable as Export () +import Dhall.Syntax.MultiLet as Export +import Dhall.Syntax.Operations as Export +import Dhall.Syntax.RecordField as Export +import Dhall.Syntax.Types as Export +import Dhall.Syntax.Var as Export diff --git a/dhall/src/Dhall/Syntax/Expr.hs b/dhall/src/Dhall/Syntax/Expr.hs index c8e96e711..a97919ee3 100644 --- a/dhall/src/Dhall/Syntax/Expr.hs +++ b/dhall/src/Dhall/Syntax/Expr.hs @@ -10,21 +10,22 @@ module Dhall.Syntax.Expr ( Expr(..) ) where -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Sequence (Seq) -import Data.String (IsString (..)) -import Data.Text (Text) -import Data.Traversable () -import Dhall.Map (Map) -import {-# SOURCE #-} Dhall.Pretty.Internal (CharacterSet (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Sequence (Seq) +import Data.String (IsString (..)) +import Data.Text (Text) +import Data.Traversable () +import Dhall.Map (Map) +import {-# SOURCE #-} Dhall.Pretty.Internal (CharacterSet (..)) import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Const +import Dhall.Syntax.FunctionBinding import Dhall.Syntax.RecordField -import {-# SOURCE #-} Dhall.Syntax.Types +import Dhall.Syntax.Types import Dhall.Syntax.Var -import GHC.Generics (Generic) -import Numeric.Natural (Natural) +import GHC.Generics (Generic) +import Numeric.Natural (Natural) import qualified Data.Time as Time diff --git a/dhall/src/Dhall/Syntax/FunctionBinding.hs b/dhall/src/Dhall/Syntax/FunctionBinding.hs new file mode 100644 index 000000000..36498affc --- /dev/null +++ b/dhall/src/Dhall/Syntax/FunctionBinding.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DeriveGeneric #-} + +{-| This module contains the core syntax types. +-} + +module Dhall.Syntax.FunctionBinding ( + FunctionBinding(..) + , makeFunctionBinding + + -- * Optics + , functionBindingExprs + ) where + +import Data.Text (Text) +import {-# SOURCE #-} Dhall.Syntax.Expr (Expr) +import GHC.Generics (Generic) + +-- | Record the label of a function or a function-type expression +-- +-- For example, +-- +-- > λ({- A -} a {- B -} : {- C -} T) -> e +-- +-- … will be instantiated as follows: +-- +-- * @functionBindingSrc0@ corresponds to the @A@ comment +-- * @functionBindingVariable@ is @a@ +-- * @functionBindingSrc1@ corresponds to the @B@ comment +-- * @functionBindingSrc2@ corresponds to the @C@ comment +-- * @functionBindingAnnotation@ is @T@ +data FunctionBinding s a = FunctionBinding + { functionBindingSrc0 :: Maybe s + , functionBindingVariable :: Text + , functionBindingSrc1 :: Maybe s + , functionBindingSrc2 :: Maybe s + , functionBindingAnnotation :: Expr s a + } deriving Generic + +-- | Smart constructor for 'FunctionBinding' with no src information +makeFunctionBinding :: Text -> Expr s a -> FunctionBinding s a +makeFunctionBinding l t = FunctionBinding Nothing l Nothing Nothing t + +{-| Traverse over the immediate 'Expr' children in a 'FunctionBinding'. +-} +functionBindingExprs + :: Applicative f + => (Expr s a -> f (Expr s b)) + -> FunctionBinding s a -> f (FunctionBinding s b) +functionBindingExprs f (FunctionBinding s0 label s1 s2 type_) = + FunctionBinding + <$> pure s0 + <*> pure label + <*> pure s1 + <*> pure s2 + <*> f type_ +{-# INLINABLE functionBindingExprs #-} diff --git a/dhall/src/Dhall/Syntax/Instances/Applicative.hs b/dhall/src/Dhall/Syntax/Instances/Applicative.hs index 169cbd9e0..b099bc743 100644 --- a/dhall/src/Dhall/Syntax/Instances/Applicative.hs +++ b/dhall/src/Dhall/Syntax/Instances/Applicative.hs @@ -4,10 +4,10 @@ module Dhall.Syntax.Instances.Applicative () where import Dhall.Syntax.Binding import Dhall.Syntax.Expr +import Dhall.Syntax.FunctionBinding import Dhall.Syntax.Instances.Functor () import Dhall.Syntax.Operations import Dhall.Syntax.RecordField -import Dhall.Syntax.Types import qualified Lens.Family as Lens diff --git a/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs b/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs index 9c5555ba5..b0a763e9f 100644 --- a/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs +++ b/dhall/src/Dhall/Syntax/Instances/Bifunctor.hs @@ -5,10 +5,10 @@ module Dhall.Syntax.Instances.Bifunctor () where import Data.Bifunctor (Bifunctor (..)) import Dhall.Syntax.Binding import Dhall.Syntax.Expr +import Dhall.Syntax.FunctionBinding import Dhall.Syntax.Instances.Functor () import Dhall.Syntax.Operations import Dhall.Syntax.RecordField -import Dhall.Syntax.Types import qualified Lens.Family as Lens diff --git a/dhall/src/Dhall/Syntax/Instances/Data.hs b/dhall/src/Dhall/Syntax/Instances/Data.hs index 7a620743f..0d1dd69b1 100644 --- a/dhall/src/Dhall/Syntax/Instances/Data.hs +++ b/dhall/src/Dhall/Syntax/Instances/Data.hs @@ -5,11 +5,12 @@ module Dhall.Syntax.Instances.Data () where -import Data.Data (Data) +import Data.Data (Data) import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr +import Dhall.Syntax.FunctionBinding import Dhall.Syntax.RecordField import Dhall.Syntax.Types import Dhall.Syntax.Var diff --git a/dhall/src/Dhall/Syntax/Instances/Eq.hs b/dhall/src/Dhall/Syntax/Instances/Eq.hs index 99e8f9de8..e770f8a38 100644 --- a/dhall/src/Dhall/Syntax/Instances/Eq.hs +++ b/dhall/src/Dhall/Syntax/Instances/Eq.hs @@ -4,11 +4,12 @@ module Dhall.Syntax.Instances.Eq () where -import Data.Bits (xor) +import Data.Bits (xor) import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr +import Dhall.Syntax.FunctionBinding import Dhall.Syntax.Import import Dhall.Syntax.RecordField import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Foldable.hs b/dhall/src/Dhall/Syntax/Instances/Foldable.hs index beae1e36c..5bec6d1e0 100644 --- a/dhall/src/Dhall/Syntax/Instances/Foldable.hs +++ b/dhall/src/Dhall/Syntax/Instances/Foldable.hs @@ -8,6 +8,7 @@ module Dhall.Syntax.Instances.Foldable () where import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Expr +import Dhall.Syntax.FunctionBinding import Dhall.Syntax.RecordField import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Functor.hs b/dhall/src/Dhall/Syntax/Instances/Functor.hs index c66a6d44b..516ea88c3 100644 --- a/dhall/src/Dhall/Syntax/Instances/Functor.hs +++ b/dhall/src/Dhall/Syntax/Instances/Functor.hs @@ -8,7 +8,8 @@ module Dhall.Syntax.Instances.Functor () where import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Expr -import {-# SOURCE #-} Dhall.Syntax.Operations (unsafeSubExpressions) +import Dhall.Syntax.FunctionBinding +import {-# SOURCE #-} Dhall.Syntax.Operations (unsafeSubExpressions) import Dhall.Syntax.RecordField import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Lift.hs b/dhall/src/Dhall/Syntax/Instances/Lift.hs index b4bcecde8..50a0bd163 100644 --- a/dhall/src/Dhall/Syntax/Instances/Lift.hs +++ b/dhall/src/Dhall/Syntax/Instances/Lift.hs @@ -9,10 +9,11 @@ import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr +import Dhall.Syntax.FunctionBinding import Dhall.Syntax.RecordField import Dhall.Syntax.Types import Dhall.Syntax.Var -import Language.Haskell.TH.Syntax (Lift) +import Language.Haskell.TH.Syntax (Lift) import qualified Data.Fixed as Fixed import qualified Data.Time as Time diff --git a/dhall/src/Dhall/Syntax/Instances/NFData.hs b/dhall/src/Dhall/Syntax/Instances/NFData.hs index 2d6b99786..a6016cc49 100644 --- a/dhall/src/Dhall/Syntax/Instances/NFData.hs +++ b/dhall/src/Dhall/Syntax/Instances/NFData.hs @@ -2,11 +2,12 @@ module Dhall.Syntax.Instances.NFData () where -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData) import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr +import Dhall.Syntax.FunctionBinding import Dhall.Syntax.Import import Dhall.Syntax.RecordField import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Ord.hs b/dhall/src/Dhall/Syntax/Instances/Ord.hs index 83cc92dc0..86b7550a7 100644 --- a/dhall/src/Dhall/Syntax/Instances/Ord.hs +++ b/dhall/src/Dhall/Syntax/Instances/Ord.hs @@ -8,8 +8,9 @@ import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr +import Dhall.Syntax.FunctionBinding import Dhall.Syntax.Import -import Dhall.Syntax.Instances.Eq () +import Dhall.Syntax.Instances.Eq () import Dhall.Syntax.RecordField import Dhall.Syntax.Types import Dhall.Syntax.Var diff --git a/dhall/src/Dhall/Syntax/Instances/Show.hs b/dhall/src/Dhall/Syntax/Instances/Show.hs index 25b94334d..4c7f7c2f2 100644 --- a/dhall/src/Dhall/Syntax/Instances/Show.hs +++ b/dhall/src/Dhall/Syntax/Instances/Show.hs @@ -8,6 +8,7 @@ import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Const import Dhall.Syntax.Expr +import Dhall.Syntax.FunctionBinding import Dhall.Syntax.Import import Dhall.Syntax.RecordField import Dhall.Syntax.Types diff --git a/dhall/src/Dhall/Syntax/Instances/Traversable.hs b/dhall/src/Dhall/Syntax/Instances/Traversable.hs index 754d9c6f3..93d42f412 100644 --- a/dhall/src/Dhall/Syntax/Instances/Traversable.hs +++ b/dhall/src/Dhall/Syntax/Instances/Traversable.hs @@ -8,6 +8,7 @@ module Dhall.Syntax.Instances.Traversable () where import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Expr +import Dhall.Syntax.FunctionBinding import Dhall.Syntax.Instances.Foldable () import Dhall.Syntax.Instances.Functor () import Dhall.Syntax.RecordField diff --git a/dhall/src/Dhall/Syntax/Operations.hs b/dhall/src/Dhall/Syntax/Operations.hs index 4a5e41673..1c46a581e 100644 --- a/dhall/src/Dhall/Syntax/Operations.hs +++ b/dhall/src/Dhall/Syntax/Operations.hs @@ -7,7 +7,6 @@ module Dhall.Syntax.Operations ( subExpressions , subExpressionsWith , unsafeSubExpressions - , functionBindingExprs -- ** Handling 'Note's , denote @@ -25,16 +24,17 @@ module Dhall.Syntax.Operations ( , shift ) where -import Data.HashSet (HashSet) -import Data.Text (Text) -import Data.Void (Void) -import Dhall.Syntax.Binding (Binding (..), bindingExprs) -import Dhall.Syntax.Chunks (chunkExprs) +import Data.HashSet (HashSet) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Syntax.Binding (Binding (..), bindingExprs) +import Dhall.Syntax.Chunks (chunkExprs) import Dhall.Syntax.Expr -import Dhall.Syntax.RecordField (RecordField (..), recordFieldExprs) +import Dhall.Syntax.FunctionBinding +import Dhall.Syntax.RecordField (RecordField (..), recordFieldExprs) import Dhall.Syntax.Types import Dhall.Syntax.Var -import Unsafe.Coerce (unsafeCoerce) +import Unsafe.Coerce (unsafeCoerce) import qualified Data.HashSet import qualified Data.Text @@ -158,21 +158,6 @@ unhandledConstructor constructor = <> " construtor" ) -{-| Traverse over the immediate 'Expr' children in a 'FunctionBinding'. --} -functionBindingExprs - :: Applicative f - => (Expr s a -> f (Expr s b)) - -> FunctionBinding s a -> f (FunctionBinding s b) -functionBindingExprs f (FunctionBinding s0 label s1 s2 type_) = - FunctionBinding - <$> pure s0 - <*> pure label - <*> pure s1 - <*> pure s2 - <*> f type_ -{-# INLINABLE functionBindingExprs #-} - -- | Remove all `Note` constructors from an `Expr` (i.e. de-`Note`) -- -- This also remove CharacterSet annotations. diff --git a/dhall/src/Dhall/Syntax/Types.hs b/dhall/src/Dhall/Syntax/Types.hs index ca27c64d1..330e1ba34 100644 --- a/dhall/src/Dhall/Syntax/Types.hs +++ b/dhall/src/Dhall/Syntax/Types.hs @@ -5,20 +5,15 @@ module Dhall.Syntax.Types ( -- * 'Expr' - CharacterSet(..) - , DhallDouble(..) + DhallDouble(..) , PreferAnnotation(..) - , FunctionBinding(..) - , makeFunctionBinding , FieldSelection(..) , makeFieldSelection , WithComponent(..) ) where -import Data.Text (Text) -import {-# SOURCE #-} Dhall.Pretty.Internal (CharacterSet (..)) -import Dhall.Syntax.Expr (Expr (..)) -import GHC.Generics (Generic) +import Data.Text (Text) +import GHC.Generics (Generic) -- $setup -- >>> import Dhall.Binary () -- For the orphan instance for `Serialise (Expr Void Import)` @@ -35,31 +30,6 @@ data PreferAnnotation | PreferFromCompletion deriving Generic --- | Record the label of a function or a function-type expression --- --- For example, --- --- > λ({- A -} a {- B -} : {- C -} T) -> e --- --- … will be instantiated as follows: --- --- * @functionBindingSrc0@ corresponds to the @A@ comment --- * @functionBindingVariable@ is @a@ --- * @functionBindingSrc1@ corresponds to the @B@ comment --- * @functionBindingSrc2@ corresponds to the @C@ comment --- * @functionBindingAnnotation@ is @T@ -data FunctionBinding s a = FunctionBinding - { functionBindingSrc0 :: Maybe s - , functionBindingVariable :: Text - , functionBindingSrc1 :: Maybe s - , functionBindingSrc2 :: Maybe s - , functionBindingAnnotation :: Expr s a - } deriving Generic - --- | Smart constructor for 'FunctionBinding' with no src information -makeFunctionBinding :: Text -> Expr s a -> FunctionBinding s a -makeFunctionBinding l t = FunctionBinding Nothing l Nothing Nothing t - -- | Record the field on a selector-expression -- -- For example, diff --git a/dhall/src/Dhall/Syntax/Types.hs-boot b/dhall/src/Dhall/Syntax/Types.hs-boot index 66d022697..489e8a694 100644 --- a/dhall/src/Dhall/Syntax/Types.hs-boot +++ b/dhall/src/Dhall/Syntax/Types.hs-boot @@ -4,8 +4,6 @@ data DhallDouble data PreferAnnotation -data FunctionBinding s a - data FieldSelection s data WithComponent From ccffe7f955e3ecf89261967fd8ce77be599efbca Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 16 Sep 2022 20:04:57 +0200 Subject: [PATCH 09/13] Fixed formatting and removed some stale comments --- dhall/src/Dhall/Syntax/Binding.hs | 7 ++----- dhall/src/Dhall/Syntax/Chunks.hs | 17 +++++++---------- dhall/src/Dhall/Syntax/Const.hs | 4 ++-- dhall/src/Dhall/Syntax/Expr.hs | 6 ------ dhall/src/Dhall/Syntax/FunctionBinding.hs | 9 +++------ dhall/src/Dhall/Syntax/Import.hs | 7 ++----- dhall/src/Dhall/Syntax/MultiLet.hs | 4 ++-- dhall/src/Dhall/Syntax/Operations.hs | 14 +++++++------- dhall/src/Dhall/Syntax/RecordField.hs | 9 +++------ dhall/src/Dhall/Syntax/Types.hs | 11 ++--------- dhall/src/Dhall/Syntax/Var.hs | 4 ++-- 11 files changed, 32 insertions(+), 60 deletions(-) diff --git a/dhall/src/Dhall/Syntax/Binding.hs b/dhall/src/Dhall/Syntax/Binding.hs index 30c350978..d782c6e0a 100644 --- a/dhall/src/Dhall/Syntax/Binding.hs +++ b/dhall/src/Dhall/Syntax/Binding.hs @@ -1,10 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} -{-| This module contains the core syntax types. --} - -module Dhall.Syntax.Binding ( - Binding(..) +module Dhall.Syntax.Binding + ( Binding(..) , makeBinding -- * Optics diff --git a/dhall/src/Dhall/Syntax/Chunks.hs b/dhall/src/Dhall/Syntax/Chunks.hs index 42f77873a..b96ea469b 100644 --- a/dhall/src/Dhall/Syntax/Chunks.hs +++ b/dhall/src/Dhall/Syntax/Chunks.hs @@ -1,20 +1,17 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-| This module contains the core syntax types. --} - -module Dhall.Syntax.Chunks ( - Chunks(..) +module Dhall.Syntax.Chunks + ( Chunks(..) -- * Optics - , chunkExprs + , chunkExprs -- * `Data.Text.Text` manipulation - , toDoubleQuoted - , longestSharedWhitespacePrefix - , linesLiteral - , unlinesLiteral + , toDoubleQuoted + , longestSharedWhitespacePrefix + , linesLiteral + , unlinesLiteral ) where import Data.List.NonEmpty (NonEmpty (..)) diff --git a/dhall/src/Dhall/Syntax/Const.hs b/dhall/src/Dhall/Syntax/Const.hs index 922034ad7..da493372f 100644 --- a/dhall/src/Dhall/Syntax/Const.hs +++ b/dhall/src/Dhall/Syntax/Const.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} -module Dhall.Syntax.Const ( - Const(..) +module Dhall.Syntax.Const + ( Const(..) ) where import GHC.Generics (Generic) diff --git a/dhall/src/Dhall/Syntax/Expr.hs b/dhall/src/Dhall/Syntax/Expr.hs index a97919ee3..4adcf1d18 100644 --- a/dhall/src/Dhall/Syntax/Expr.hs +++ b/dhall/src/Dhall/Syntax/Expr.hs @@ -1,11 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} -{-| This module contains the core syntax types and optics for them. - -'reservedIdentifiers', 'denote' and friends are included because they are -involved in a dependency circle with "Dhall.Pretty.Internal". --} - module Dhall.Syntax.Expr ( Expr(..) ) where diff --git a/dhall/src/Dhall/Syntax/FunctionBinding.hs b/dhall/src/Dhall/Syntax/FunctionBinding.hs index 36498affc..344ddef0a 100644 --- a/dhall/src/Dhall/Syntax/FunctionBinding.hs +++ b/dhall/src/Dhall/Syntax/FunctionBinding.hs @@ -1,13 +1,10 @@ {-# LANGUAGE DeriveGeneric #-} -{-| This module contains the core syntax types. --} - -module Dhall.Syntax.FunctionBinding ( - FunctionBinding(..) +module Dhall.Syntax.FunctionBinding + ( FunctionBinding(..) , makeFunctionBinding - -- * Optics + -- * Optics , functionBindingExprs ) where diff --git a/dhall/src/Dhall/Syntax/Import.hs b/dhall/src/Dhall/Syntax/Import.hs index a44f9afc1..ecbdc12e5 100644 --- a/dhall/src/Dhall/Syntax/Import.hs +++ b/dhall/src/Dhall/Syntax/Import.hs @@ -2,11 +2,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-| This module contains the core syntax types. --} - -module Dhall.Syntax.Import ( - Directory(..) +module Dhall.Syntax.Import + ( Directory(..) , File(..) , FilePrefix(..) , Import(..) diff --git a/dhall/src/Dhall/Syntax/MultiLet.hs b/dhall/src/Dhall/Syntax/MultiLet.hs index 7802f1537..94f0bdf8a 100644 --- a/dhall/src/Dhall/Syntax/MultiLet.hs +++ b/dhall/src/Dhall/Syntax/MultiLet.hs @@ -18,8 +18,8 @@ https://gitlab.haskell.org/ghc/ghc/issues/17096 This should be fixed by GHC-8.10, so it might be worth revisiting then. -} -module Dhall.Syntax.MultiLet ( - MultiLet(..) +module Dhall.Syntax.MultiLet + ( MultiLet(..) , multiLet , wrapInLets ) where diff --git a/dhall/src/Dhall/Syntax/Operations.hs b/dhall/src/Dhall/Syntax/Operations.hs index 1c46a581e..91cb3fff4 100644 --- a/dhall/src/Dhall/Syntax/Operations.hs +++ b/dhall/src/Dhall/Syntax/Operations.hs @@ -2,25 +2,25 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -module Dhall.Syntax.Operations ( - -- ** Optics +module Dhall.Syntax.Operations + ( -- * Optics subExpressions , subExpressionsWith , unsafeSubExpressions - -- ** Handling 'Note's + -- * Handling 'Note's , denote , renote , shallowDenote - -- * Reserved identifiers + -- * Reserved identifiers , reservedIdentifiers , reservedKeywords - -- * Utilities + -- * Utilities , internalError - -- `shift` should really be in `Dhall.Normalize`, but it's here to avoid a - -- module cycle + -- `shift` should really be in `Dhall.Normalize`, but it's here to avoid a + -- module cycle , shift ) where diff --git a/dhall/src/Dhall/Syntax/RecordField.hs b/dhall/src/Dhall/Syntax/RecordField.hs index 9df39f05c..52b56d940 100644 --- a/dhall/src/Dhall/Syntax/RecordField.hs +++ b/dhall/src/Dhall/Syntax/RecordField.hs @@ -1,13 +1,10 @@ {-# LANGUAGE DeriveGeneric #-} -{-| This module contains the core syntax types. --} - -module Dhall.Syntax.RecordField ( - RecordField(..) +module Dhall.Syntax.RecordField + ( RecordField(..) , makeRecordField - -- * Optics + -- * Optics , recordFieldExprs ) where diff --git a/dhall/src/Dhall/Syntax/Types.hs b/dhall/src/Dhall/Syntax/Types.hs index 330e1ba34..00ab8276e 100644 --- a/dhall/src/Dhall/Syntax/Types.hs +++ b/dhall/src/Dhall/Syntax/Types.hs @@ -1,11 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} -{-| This module contains the core syntax types. --} - -module Dhall.Syntax.Types ( - -- * 'Expr' - DhallDouble(..) +module Dhall.Syntax.Types + ( DhallDouble(..) , PreferAnnotation(..) , FieldSelection(..) , makeFieldSelection @@ -15,9 +11,6 @@ module Dhall.Syntax.Types ( import Data.Text (Text) import GHC.Generics (Generic) --- $setup --- >>> import Dhall.Binary () -- For the orphan instance for `Serialise (Expr Void Import)` - -- | This wrapper around 'Prelude.Double' exists for its 'Eq' instance which is -- defined via the binary encoding of Dhall @Double@s. newtype DhallDouble = DhallDouble { getDhallDouble :: Double } diff --git a/dhall/src/Dhall/Syntax/Var.hs b/dhall/src/Dhall/Syntax/Var.hs index 291032a25..5662b662e 100644 --- a/dhall/src/Dhall/Syntax/Var.hs +++ b/dhall/src/Dhall/Syntax/Var.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} -module Dhall.Syntax.Var ( - Var(..) +module Dhall.Syntax.Var + ( Var(..) ) where import Data.String (IsString (..)) From 1fda1a8b5706ac865a6219b4e90679c0479b64f3 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Mon, 19 Sep 2022 23:46:46 +0200 Subject: [PATCH 10/13] Fixed some haddocks --- dhall/src/Dhall/Syntax/Expr.hs | 21 ++++++++++++--------- dhall/src/Dhall/Syntax/Types.hs | 6 +++--- 2 files changed, 15 insertions(+), 12 deletions(-) diff --git a/dhall/src/Dhall/Syntax/Expr.hs b/dhall/src/Dhall/Syntax/Expr.hs index 4adcf1d18..cd896d933 100644 --- a/dhall/src/Dhall/Syntax/Expr.hs +++ b/dhall/src/Dhall/Syntax/Expr.hs @@ -25,17 +25,20 @@ import qualified Data.Time as Time {-| Syntax tree for expressions - The @s@ type parameter is used to track the presence or absence of `Src` - spans: + The @s@ type parameter is used to track the presence or absence of + `Dhall.Src.Src` spans: - * If @s = `Src`@ then the code may contains `Src` spans (either in a `Note` - constructor or inline within another constructor, like `Let`) - * If @s = `Void`@ then the code has no `Src` spans + * If @s = `Dhall.Src.Src`@ then the code may contains `Dhall.Src.Src` spans + (either in a `Note` constructor or inline within another constructor, like + `Let`) + * If @s = `Data.Void.Void`@ then the code has no `Dhall.Src.Src` spans The @a@ type parameter is used to track the presence or absence of imports - * If @a = `Import`@ then the code may contain unresolved `Import`s - * If @a = `Void`@ then the code has no `Import`s + * If @a = `Dhall.Syntax.Import.Import`@ then the code may contain unresolved + `Dhall.Syntax.Import.Import`s + * If @a = `Data.Void.Void`@ then the code has no + `Dhall.Syntax.Import.Import`s -} data Expr s a -- | > Const c ~ c @@ -64,8 +67,8 @@ data Expr s a -- is only an additional 'Note' around @'Let' "y" …@ in the second -- example. -- - -- See 'MultiLet' for a representation of let-blocks that mirrors the - -- source code more closely. + -- See `Dhall.Syntax.MultiLet.MultiLet` for a representation of let-blocks + -- that mirrors the source code more closely. | Let (Binding s a) (Expr s a) -- | > Annot x t ~ x : t | Annot (Expr s a) (Expr s a) diff --git a/dhall/src/Dhall/Syntax/Types.hs b/dhall/src/Dhall/Syntax/Types.hs index 00ab8276e..0eab73ffd 100644 --- a/dhall/src/Dhall/Syntax/Types.hs +++ b/dhall/src/Dhall/Syntax/Types.hs @@ -37,9 +37,9 @@ data PreferAnnotation -- -- Given our limitation that not all expressions recover their whitespaces, the -- purpose of @fieldSelectionSrc1@ is to save the 'Text.Megaparsec.SourcePos' --- where the @fieldSelectionLabel@ ends, but we /still/ use a 'Maybe Src' --- (@s = 'Src'@) to be consistent with similar data types such as 'Binding', for --- example. +-- where the @fieldSelectionLabel@ ends, but we /still/ use a +-- 'Maybe Dhall.Src.Src' (@s = 'Dhall.Src.Src'@) to be consistent with similar +-- data types such as 'Dhall.Syntax.Binding.Binding', for example. data FieldSelection s = FieldSelection { fieldSelectionSrc0 :: Maybe s , fieldSelectionLabel :: !Text From 2687007c263b3f65c1f802e30b1631bbb09e988d Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Tue, 20 Sep 2022 00:34:13 +0200 Subject: [PATCH 11/13] Be a bit more chatty in haddockPhase --- nix/shared.nix | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/nix/shared.nix b/nix/shared.nix index 3c95c8578..685de573d 100644 --- a/nix/shared.nix +++ b/nix/shared.nix @@ -81,7 +81,10 @@ let drv.overrideAttrs (old: { postHaddock = (old.postHaddock or "") + '' - ! (./Setup haddock 2>&1 | grep --quiet 'Missing documentation for:\|Warning:.*is out of scope') || (echo "Error: Incomplete haddocks"; exit 1) + if ./Setup haddock 2>&1 | grep --quiet 'Missing documentation for:\|Warning:.*is out of scope'; then + ./Setup haddock 2>&1 + echo "Error: Incomplete haddocks"; exit 1 + fi ''; } ) From 17babaca49f13426c39a1a063cac9960775cd71c Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Tue, 20 Sep 2022 21:50:15 +0200 Subject: [PATCH 12/13] Fixed doctest import --- dhall/src/Dhall/Syntax/Instances/Eq.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/dhall/src/Dhall/Syntax/Instances/Eq.hs b/dhall/src/Dhall/Syntax/Instances/Eq.hs index e770f8a38..48fa51abb 100644 --- a/dhall/src/Dhall/Syntax/Instances/Eq.hs +++ b/dhall/src/Dhall/Syntax/Instances/Eq.hs @@ -15,6 +15,9 @@ import Dhall.Syntax.RecordField import Dhall.Syntax.Types import Dhall.Syntax.Var +-- $setup +-- >>> import Data.Void (Void) + deriving instance Eq Const deriving instance Eq Var deriving instance (Eq s, Eq a) => Eq (Binding s a) From 34b8e7b92db725e0171dcd1e0f9930734db3b10e Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Tue, 20 Sep 2022 22:22:31 +0200 Subject: [PATCH 13/13] Fixed doctest import --- dhall/src/Dhall/Syntax/Instances/Eq.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/dhall/src/Dhall/Syntax/Instances/Eq.hs b/dhall/src/Dhall/Syntax/Instances/Eq.hs index 48fa51abb..3b9d0683b 100644 --- a/dhall/src/Dhall/Syntax/Instances/Eq.hs +++ b/dhall/src/Dhall/Syntax/Instances/Eq.hs @@ -17,6 +17,7 @@ import Dhall.Syntax.Var -- $setup -- >>> import Data.Void (Void) +-- >>> import Dhall.Binary () -- For the orphan instance for `Serialise (Expr Void Import)` deriving instance Eq Const deriving instance Eq Var