{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UnicodeSyntax #-}
module Dhall.Syntax (
Const(..)
, Var(..)
, Binding(..)
, makeBinding
, Chunks(..)
, DhallDouble(..)
, PreferAnnotation(..)
, Expr(..)
, RecordField(..)
, makeRecordField
, FunctionBinding(..)
, makeFunctionBinding
, FieldSelection(..)
, makeFieldSelection
, MultiLet(..)
, multiLet
, wrapInLets
, subExpressions
, unsafeSubExpressions
, chunkExprs
, bindingExprs
, recordFieldExprs
, functionBindingExprs
, denote
, renote
, shallowDenote
, Directory(..)
, File(..)
, FilePrefix(..)
, Import(..)
, ImportHashed(..)
, ImportMode(..)
, ImportType(..)
, URL(..)
, Scheme(..)
, pathCharacter
, reservedIdentifiers
, reservedKeywords
, toDoubleQuoted
, longestSharedWhitespacePrefix
, linesLiteral
, unlinesLiteral
, desugarWith
, internalError
, shift
) 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.Text.Prettyprint.Doc (Doc, Pretty)
import Data.Traversable ()
import Data.Void (Void)
import Dhall.Map (Map)
import {-# SOURCE #-} Dhall.Pretty.Internal
import Dhall.Set (Set)
import Dhall.Src (Src (..))
import GHC.Generics (Generic)
import Instances.TH.Lift ()
import Language.Haskell.TH.Syntax (Lift)
import Numeric.Natural (Natural)
import Unsafe.Coerce (unsafeCoerce)
import qualified Control.Monad
import qualified Data.HashSet
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text
import qualified Data.Text.Prettyprint.Doc as Pretty
import qualified Dhall.Crypto
import qualified Dhall.Optics as Optics
import qualified Lens.Family as Lens
import qualified Network.URI as URI
data Const = Type | Kind | Sort
deriving (Show, Eq, Ord, Data, Bounded, Enum, Generic, Lift, NFData)
instance Pretty Const where
pretty = Pretty.unAnnotate . prettyConst
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
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
makeBinding :: Text -> Expr s a -> Binding s a
makeBinding name = Binding Nothing name Nothing Nothing Nothing
newtype DhallDouble = DhallDouble { getDhallDouble :: Double }
deriving (Show, Data, Lift, NFData, Generic)
instance Eq DhallDouble where
DhallDouble a == DhallDouble b
| isNaN a && isNaN b = True
| isNegativeZero a `xor` isNegativeZero b = False
| otherwise = a == b
instance Ord DhallDouble where
compare a@(DhallDouble a') b@(DhallDouble b') =
if a == b
then EQ
else compare a' b'
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)
data PreferAnnotation s a
= PreferFromSource
| PreferFromWith (Expr s a)
| 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
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)
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
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)
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
data FieldSelection s = FieldSelection
{ fieldSelectionSrc0 :: Maybe s
, fieldSelectionLabel :: !Text
, fieldSelectionSrc1 :: Maybe s
} deriving (Data, Eq, Foldable, Functor, Generic, Lift, NFData, Ord, Show, Traversable)
makeFieldSelection :: Text -> FieldSelection s
makeFieldSelection t = FieldSelection Nothing t Nothing
data Expr s a
= Const Const
| Var Var
| Lam (FunctionBinding s a) (Expr s a)
| Pi Text (Expr s a) (Expr s a)
| App (Expr s a) (Expr s a)
| Let (Binding s a) (Expr s a)
| Annot (Expr s a) (Expr s a)
| Bool
| BoolLit Bool
| BoolAnd (Expr s a) (Expr s a)
| BoolOr (Expr s a) (Expr s a)
| BoolEQ (Expr s a) (Expr s a)
| BoolNE (Expr s a) (Expr s a)
| BoolIf (Expr s a) (Expr s a) (Expr s a)
| Natural
| NaturalLit Natural
| NaturalFold
| NaturalBuild
| NaturalIsZero
| NaturalEven
| NaturalOdd
| NaturalToInteger
| NaturalShow
| NaturalSubtract
| NaturalPlus (Expr s a) (Expr s a)
| NaturalTimes (Expr s a) (Expr s a)
| Integer
| IntegerLit Integer
| IntegerClamp
| IntegerNegate
| IntegerShow
| IntegerToDouble
| Double
| DoubleLit DhallDouble
| DoubleShow
| Text
| TextLit (Chunks s a)
| TextAppend (Expr s a) (Expr s a)
| TextReplace
| TextShow
| List
| ListLit (Maybe (Expr s a)) (Seq (Expr s a))
| ListAppend (Expr s a) (Expr s a)
| ListBuild
| ListFold
| ListLength
| ListHead
| ListLast
| ListIndexed
| ListReverse
| Optional
| Some (Expr s a)
| None
| Record (Map Text (RecordField s a))
| RecordLit (Map Text (RecordField s a))
| Union (Map Text (Maybe (Expr s a)))
| Combine (Maybe Text) (Expr s a) (Expr s a)
| CombineTypes (Expr s a) (Expr s a)
| Prefer (PreferAnnotation s a) (Expr s a) (Expr s a)
| RecordCompletion (Expr s a) (Expr s a)
| Merge (Expr s a) (Expr s a) (Maybe (Expr s a))
| ToMap (Expr s a) (Maybe (Expr s a))
| Field (Expr s a) (FieldSelection s)
| Project (Expr s a) (Either (Set Text) (Expr s a))
| Assert (Expr s a)
| Equivalent (Expr s a) (Expr s a)
| With (Expr s a) (NonEmpty Text) (Expr s a)
| Note s (Expr s a)
| ImportAlt (Expr s a) (Expr s a)
| Embed a
deriving (Foldable, Generic, Traversable, Show, Data, Lift, NFData)
deriving instance (Eq s, Eq a) => Eq (Expr s a)
deriving instance (Ord s, Ord a) => Ord (Expr s a)
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 fb e) = Lam (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 a b -> Lam (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 a b ) = Lam (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)
instance Pretty a => Pretty (Expr s a) where
pretty = Pretty.unAnnotate . prettyExpr
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
wrapInLets :: Foldable f => f (Binding s a) -> Expr s a -> Expr s a
wrapInLets bs e = foldr Let e bs
data MultiLet s a = MultiLet (NonEmpty (Binding s a)) (Expr s a)
subExpressions
:: Applicative f => (Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a)
subExpressions _ (Embed a) = pure (Embed a)
subExpressions f (Note a b) = Note a <$> f b
subExpressions f (Let a b) = Let <$> bindingExprs f a <*> f b
subExpressions f (Record a) = Record <$> traverse (recordFieldExprs f) a
subExpressions f (RecordLit a) = RecordLit <$> traverse (recordFieldExprs f) a
subExpressions f (Lam fb e) = Lam <$> functionBindingExprs f fb <*> f e
subExpressions f (Field a b) = Field <$> f a <*> pure b
subExpressions f expression = unsafeSubExpressions f expression
{-# INLINABLE subExpressions #-}
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 a b c) = Pi 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 _ 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 a b c) = Combine a <$> f b <*> f c
unsafeSubExpressions f (CombineTypes a b) = CombineTypes <$> f a <*> f b
unsafeSubExpressions f (Prefer a b c) = Prefer <$> 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 (Project a b) = Project <$> f a <*> traverse f b
unsafeSubExpressions f (Assert a) = Assert <$> f a
unsafeSubExpressions f (Equivalent a b) = Equivalent <$> 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"
)
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 #-}
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
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_
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 #-}
newtype Directory = Directory { components :: [Text] }
deriving (Eq, Generic, Ord, Show, 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 <> "\""
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
data FilePrefix
= Absolute
| Here
| Parent
| Home
deriving (Eq, Generic, Ord, Show, NFData)
instance Pretty FilePrefix where
pretty Absolute = ""
pretty Here = "."
pretty Parent = ".."
pretty Home = "~"
data Scheme = HTTP | HTTPS deriving (Eq, Generic, Ord, Show, NFData)
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 (prettyImportExpression 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
data ImportType
= Local FilePrefix File
| Remote URL
| Env Text
| 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"
data ImportMode = Code | RawText | Location
deriving (Eq, Generic, Ord, Show, NFData)
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.pretty p <> " sha256:" <> Pretty.pretty (show h)
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 -> ""
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'
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 (denote b) (denote c)
Record a -> Record $ denoteRecordField <$> a
RecordLit a -> RecordLit $ denoteRecordField <$> a
Lam a b -> Lam (denoteFunctionBinding a) (denote b)
Field a (FieldSelection _ b _) -> Field (denote a) (FieldSelection Nothing b Nothing)
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)
renote :: Expr Void a -> Expr s a
renote = unsafeCoerce
{-# INLINE renote #-}
shallowDenote :: Expr s a -> Expr s a
shallowDenote (Note _ e) = shallowDenote e
shallowDenote e = e
reservedKeywords :: HashSet Text
reservedKeywords =
Data.HashSet.fromList
[
"if"
, "then"
, "else"
, "let"
, "in"
, "using"
, "missing"
, "as"
, "Infinity"
, "NaN"
, "merge"
, "Some"
, "toMap"
, "assert"
, "forall"
, "with"
]
reservedIdentifiers :: HashSet Text
reservedIdentifiers = reservedKeywords <>
Data.HashSet.fromList
[
"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"
, "List"
, "Type"
, "Kind"
, "Sort"
]
splitOn :: Text -> Text -> NonEmpty Text
splitOn needle haystack =
case Data.Text.splitOn needle haystack of
[] -> "" :| []
t : ts -> t :| ts
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₀)
unlinesLiteral :: NonEmpty (Chunks s a) -> Chunks s a
unlinesLiteral chunks =
Data.Foldable.fold (NonEmpty.intersperse "\n" chunks)
emptyLine :: Chunks s a -> Bool
emptyLine (Chunks [] "" ) = True
emptyLine (Chunks [] "\r") = True
emptyLine _ = False
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
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 -> ""
filteredLines = newInit <> pure oldLast
where
oldInit = NonEmpty.init literals
oldLast = NonEmpty.last literals
newInit = filter (not . emptyLine) oldInit
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
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 :: 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 (FunctionBinding src0 x' src1 src2 _A) b) =
Lam (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 x' _A _B) = Pi 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
desugarWith :: Expr s a -> Expr s a
desugarWith = Optics.rewriteOf subExpressions rewrite
where
rewrite e@(With record (key :| []) value) =
Just
(Prefer
(PreferFromWith e)
record
(RecordLit [ (key, makeRecordField value) ])
)
rewrite e@(With record (key0 :| key1 : keys) value) =
Just
(Let
(makeBinding "_" record)
(Prefer (PreferFromWith e) "_"
(RecordLit
[ (key0, makeRecordField $ With (Field "_" (FieldSelection Nothing key0 Nothing)) (key1 :| keys) (shift 1 "_" value)) ]
)
)
)
rewrite _ = Nothing
_ERROR :: String
_ERROR = "\ESC[1;31mError\ESC[0m"
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 <> " "
, "``` "
] )