diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,18 @@ +1.5.0 + +* BREAKING CHANGE: Add list concatenation operator: `(#)` + * This is a breaking change because it adds a new constructor to the `Expr` + type which breaks exhaustive pattern matches +* BREAKING CHANGE: Add `Interpret` support for lazy `Text` + * This is a breaking change because it renames `text` to `strictText` +* Add `Interpret` instance for decoding (a limited subset of) Dhall functions +* Dhall no longer requires Template Haskell to compile + * This helps with cross-compilation +* Add `rawInput` utility for decoding a Haskell value from the `Expr` type +* Add `loadWith`/`normalizeWith` utilities for normalizing/importing modules + with a custom context +* Export `Type` constructor + 1.4.2 * Fix missing `Prelude` files in package archive uploaded to Hackage diff --git a/dhall.cabal b/dhall.cabal --- a/dhall.cabal +++ b/dhall.cabal @@ -1,5 +1,5 @@ Name: dhall -Version: 1.4.2 +Version: 1.5.0 Cabal-Version: >=1.8.0.2 Build-Type: Simple Tested-With: GHC == 7.10.2, GHC == 8.0.1 @@ -94,10 +94,10 @@ case-insensitive < 1.3 , charset < 0.4 , containers >= 0.5.0.0 && < 0.6 , + contravariant < 1.5 , http-client >= 0.4.30 && < 0.6 , http-client-tls >= 0.2.0 && < 0.4 , lens >= 2.4 && < 4.16, - neat-interpolation >= 0.3.2.1 && < 0.4 , parsers >= 0.12.4 && < 0.13, system-filepath >= 0.3.1 && < 0.5 , system-fileio >= 0.2.1 && < 0.4 , @@ -143,7 +143,6 @@ Build-Depends: base >= 4 && < 5 , dhall , - neat-interpolation >= 0.3.2.1 && < 0.4 , tasty >= 0.11.2 && < 0.12, tasty-hunit >= 0.9.2 && < 0.10, text >= 0.11.1.0 && < 1.3 , diff --git a/src/Dhall.hs b/src/Dhall.hs --- a/src/Dhall.hs +++ b/src/Dhall.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} @@ -19,7 +18,7 @@ , detailed -- * Types - , Type + , Type(..) , Interpret(..) , InvalidType(..) , auto @@ -29,11 +28,18 @@ , natural , integer , double - , text + , lazyText + , strictText , maybe , vector , GenericInterpret(..) + , Inject(..) + , inject + + -- * Miscellaneous + , rawInput + -- * Re-exports , Natural , Text @@ -41,8 +47,9 @@ , Generic ) where -import Control.Applicative (empty, liftA2, (<|>)) +import Control.Applicative (empty, liftA2, (<|>), Alternative) import Control.Exception (Exception) +import Data.Functor.Contravariant (Contravariant(..)) import Data.Monoid ((<>)) import Data.Text.Buildable (Buildable(..)) import Data.Text.Lazy (Text) @@ -69,7 +76,6 @@ import qualified Dhall.Import import qualified Dhall.Parser import qualified Dhall.TypeCheck -import qualified NeatInterpolation throws :: Exception e => Either e a -> IO a throws (Left e) = Control.Exception.throwIO e @@ -84,16 +90,15 @@ -} data InvalidType = InvalidType deriving (Typeable) -_ERROR :: Data.Text.Text +_ERROR :: String _ERROR = "\ESC[1;31mError\ESC[0m" instance Show InvalidType where - show InvalidType = Data.Text.unpack [NeatInterpolation.text| -$_ERROR: Invalid Dhall.Type - -Every Type must provide an extract function that succeeds if an expression -matches the expected type. You provided a Type that disobeys this contract -|] + show InvalidType = + _ERROR <> ": Invalid Dhall.Type \n\ + \ \n\ + \Every Type must provide an extract function that succeeds if an expression \n\ + \matches the expected type. You provided a Type that disobeys this contract \n" instance Exception InvalidType @@ -141,6 +146,27 @@ Just x -> return x Nothing -> Control.Exception.throwIO InvalidType +-- | Use this function to extract Haskell values directly from Dhall AST. +-- The intended use case is to allow easy extraction of Dhall values for +-- making the function `Dhall.Core.normalizeWith` easier to use. +-- +-- For other use cases, use `input` from `Dhall` module. It will give you +-- a much better user experience. +rawInput + :: Alternative f + => Type a + -- ^ The type of value to decode from Dhall to Haskell + -> Expr s X + -- ^ a closed form Dhall program, which evaluates to the expected type + -> f a + -- ^ The decoded value in Haskell +rawInput (Type {..}) expr = do + case extract (Dhall.Core.normalize expr) of + Just x -> pure x + Nothing -> empty + + + {-| Use this to provide more detailed error messages >> input auto "True" :: IO Integer @@ -274,8 +300,10 @@ > input :: Type a -> Text -> IO a -} data Type a = Type - { extract :: Expr X X -> Maybe a + { extract :: Expr Src X -> Maybe a + -- ^ Extracts Haskell value from the Dhall expression , expected :: Expr Src X + -- ^ Dhall type of the Haskell value } deriving (Functor) @@ -331,19 +359,27 @@ expected = Double -{-| Decode `Text` +{-| Decode lazy `Text` ->>> input text "\"Test\"" +>>> input lazyText "\"Test\"" "Test" -} -text :: Type Text -text = Type {..} +lazyText :: Type Text +lazyText = Type {..} where extract (TextLit t) = pure (Data.Text.Lazy.Builder.toLazyText t) extract _ = empty expected = Text +{-| Decode strict `Text` + +>>> input strictText "\"Test\"" +"Test" +-} +strictText :: Type Data.Text.Text +strictText = fmap Data.Text.Lazy.toStrict lazyText + {-| Decode a `Maybe` >>> input (maybe integer) "[1] : Optional Integer" @@ -401,14 +437,30 @@ autoWith _ = double instance Interpret Text where - autoWith _ = text + autoWith _ = lazyText +instance Interpret Data.Text.Text where + autoWith _ = strictText + instance Interpret a => Interpret (Maybe a) where autoWith opts = maybe (autoWith opts) instance Interpret a => Interpret (Vector a) where autoWith opts = vector (autoWith opts) +instance (Inject a, Interpret b) => Interpret (a -> b) where + autoWith opts = Type extractOut expectedOut + where + extractOut e = Just (\i -> case extractIn (Dhall.Core.normalize (App e (embed i))) of + Just o -> o + Nothing -> error "Interpret: You cannot decode a function if it does not have the correct type" ) + + expectedOut = Pi "_" declared expectedIn + + InputType {..} = inject + + Type extractIn expectedIn = autoWith opts + {-| Use the default options for interpreting a configuration file > auto = autoWith defaultInterpretOptions @@ -567,3 +619,231 @@ key = fieldModifier (Data.Text.Lazy.pack (selName n)) Type extract' expected' = autoWith opts + +{-| An @(InputType a)@ represents a way to marshal a value of type @\'a\'@ from + Haskell into Dhall +-} +data InputType a = InputType + { embed :: a -> Expr Src X + -- ^ Embeds a Haskell value as a Dhall expression + , declared :: Expr Src X + -- ^ Dhall type of the Haskell value + } + +instance Contravariant InputType where + contramap f (InputType embed declared) = InputType embed' declared + where + embed' x = embed (f x) + +{-| This class is used by `Interpret` instance for functions: + +> instance (Inject a, Interpret b) => Interpret (a -> b) + + You can convert Dhall functions with "simple" inputs (i.e. instances of this + class) into Haskell functions. This works by: + + * Marshaling the input to the Haskell function into a Dhall expression (i.e. + @x :: Expr Src X@) + * Applying the Dhall function (i.e. @f :: Expr Src X@) to the Dhall input + (i.e. @App f x@) + * Normalizing the syntax tree (i.e. @normalize (App f x)@) + * Marshaling the resulting Dhall expression back into a Haskell value +-} +class Inject a where + injectWith :: InterpretOptions -> InputType a + default injectWith + :: (Generic a, GenericInject (Rep a)) => InterpretOptions -> InputType a + injectWith options = contramap GHC.Generics.from (genericInjectWith options) + +{-| Use the default options for injecting a value + +> inject = inject defaultInterpretOptions +-} +inject :: Inject a => InputType a +inject = injectWith defaultInterpretOptions + +instance Inject Bool where + injectWith _ = InputType {..} + where + embed = BoolLit + + declared = Bool + +instance Inject Text where + injectWith _ = InputType {..} + where + embed text = TextLit (Data.Text.Lazy.Builder.fromLazyText text) + + declared = Text + +instance Inject Data.Text.Text where + injectWith _ = InputType {..} + where + embed text = TextLit (Data.Text.Lazy.Builder.fromText text) + + declared = Text + +instance Inject Natural where + injectWith _ = InputType {..} + where + embed = NaturalLit + + declared = Natural + +instance Inject Integer where + injectWith _ = InputType {..} + where + embed = IntegerLit + + declared = Integer + +instance Inject Double where + injectWith _ = InputType {..} + where + embed = DoubleLit + + declared = Double + +instance Inject a => Inject (Maybe a) where + injectWith options = InputType embedOut declaredOut + where + embedOut (Just x) = + OptionalLit declaredIn (Data.Vector.singleton (embedIn x)) + embedOut Nothing = + OptionalLit declaredIn Data.Vector.empty + + InputType embedIn declaredIn = injectWith options + + declaredOut = App Optional declaredIn + +instance Inject a => Inject (Vector a) where + injectWith options = InputType embedOut declaredOut + where + embedOut xs = ListLit (Just declaredIn) (fmap embedIn xs) + + declaredOut = App List declaredIn + + InputType embedIn declaredIn = injectWith options + +{-| This is the underlying class that powers the `Interpret` class's support + for automatically deriving a generic implementation +-} +class GenericInject f where + genericInjectWith :: InterpretOptions -> InputType (f a) + +instance GenericInject f => GenericInject (M1 D d f) where + genericInjectWith = fmap (contramap unM1) genericInjectWith + +instance GenericInject f => GenericInject (M1 C c f) where + genericInjectWith = fmap (contramap unM1) genericInjectWith + +instance (Constructor c1, Constructor c2, GenericInject f1, GenericInject f2) => GenericInject (M1 C c1 f1 :+: M1 C c2 f2) where + genericInjectWith options@(InterpretOptions {..}) = InputType {..} + where + embed (L1 (M1 l)) = UnionLit keyL (embedL l) Data.Map.empty + embed (R1 (M1 r)) = UnionLit keyR (embedR r) Data.Map.empty + + declared = + Union (Data.Map.fromList [(keyL, declaredL), (keyR, declaredR)]) + + nL :: M1 i c1 f1 a + nL = undefined + + nR :: M1 i c2 f2 a + nR = undefined + + keyL = constructorModifier (Data.Text.Lazy.pack (conName nL)) + keyR = constructorModifier (Data.Text.Lazy.pack (conName nR)) + + InputType embedL declaredL = genericInjectWith options + InputType embedR declaredR = genericInjectWith options + +instance (Constructor c, GenericInject (f :+: g), GenericInject h) => GenericInject ((f :+: g) :+: M1 C c h) where + genericInjectWith options@(InterpretOptions {..}) = InputType {..} + where + embed (L1 l) = UnionLit keyL valL (Data.Map.insert keyR declaredR ktsL') + where + UnionLit keyL valL ktsL' = embedL l + embed (R1 (M1 r)) = UnionLit keyR (embedR r) ktsL + + nR :: M1 i c h a + nR = undefined + + keyR = constructorModifier (Data.Text.Lazy.pack (conName nR)) + + declared = Union (Data.Map.insert keyR declaredR ktsL) + + InputType embedL (Union ktsL) = genericInjectWith options + InputType embedR declaredR = genericInjectWith options + +instance (Constructor c, GenericInject f, GenericInject (g :+: h)) => GenericInject (M1 C c f :+: (g :+: h)) where + genericInjectWith options@(InterpretOptions {..}) = InputType {..} + where + embed (L1 (M1 l)) = UnionLit keyL (embedL l) ktsR + embed (R1 r) = UnionLit keyR valR (Data.Map.insert keyL declaredL ktsR') + where + UnionLit keyR valR ktsR' = embedR r + + nL :: M1 i c f a + nL = undefined + + keyL = constructorModifier (Data.Text.Lazy.pack (conName nL)) + + declared = Union (Data.Map.insert keyL declaredL ktsR) + + InputType embedL declaredL = genericInjectWith options + InputType embedR (Union ktsR) = genericInjectWith options + +instance (GenericInject (f :+: g), GenericInject (h :+: i)) => GenericInject ((f :+: g) :+: (h :+: i)) where + genericInjectWith options = InputType {..} + where + embed (L1 l) = UnionLit keyL valR (Data.Map.union ktsL' ktsR) + where + UnionLit keyL valR ktsL' = embedL l + embed (R1 r) = UnionLit keyR valR (Data.Map.union ktsL ktsR') + where + UnionLit keyR valR ktsR' = embedR r + + declared = Union (Data.Map.union ktsL ktsR) + + InputType embedL (Union ktsL) = genericInjectWith options + InputType embedR (Union ktsR) = genericInjectWith options + +instance (GenericInject f, GenericInject g) => GenericInject (f :*: g) where + genericInjectWith options = InputType embedOut declaredOut + where + embedOut (l :*: r) = RecordLit (Data.Map.union mapL mapR) + where + RecordLit mapL = embedInL l + RecordLit mapR = embedInR r + + declaredOut = Record (Data.Map.union mapL mapR) + where + Record mapL = declaredInL + Record mapR = declaredInR + + InputType embedInL declaredInL = genericInjectWith options + + InputType embedInR declaredInR = genericInjectWith options + +instance GenericInject U1 where + genericInjectWith _ = InputType {..} + where + embed _ = RecordLit Data.Map.empty + + declared = Record Data.Map.empty + +instance (Selector s, Inject a) => GenericInject (M1 S s (K1 i a)) where + genericInjectWith opts@(InterpretOptions {..}) = + InputType embedOut declaredOut + where + n :: M1 i s f a + n = undefined + + name = fieldModifier (Data.Text.Lazy.pack (selName n)) + + embedOut (M1 (K1 x)) = RecordLit (Data.Map.singleton name (embedIn x)) + + declaredOut = Record (Data.Map.singleton name declaredIn) + + InputType embedIn declaredIn = injectWith opts diff --git a/src/Dhall/Core.hs b/src/Dhall/Core.hs --- a/src/Dhall/Core.hs +++ b/src/Dhall/Core.hs @@ -4,7 +4,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wall #-} @@ -27,9 +26,12 @@ -- * Normalization , normalize + , normalizeWith + , Normalizer , subst , shift , isNormalized + , isNormalizedWith -- * Pretty-printing , pretty @@ -69,7 +71,6 @@ import qualified Data.Vector import qualified Data.Vector.Mutable import qualified Filesystem.Path.CurrentOS as Filesystem -import qualified NeatInterpolation {-| Constants for a pure type system @@ -259,6 +260,8 @@ -- | > ListLit (Just t ) [x, y, z] ~ [x, y, z] : List t -- > ListLit Nothing [x, y, z] ~ [x, y, z] | ListLit (Maybe (Expr s a)) (Vector (Expr s a)) + -- | > ListAppend x y ~ x # y + | ListAppend (Expr s a) (Expr s a) -- | > ListBuild ~ List/build | ListBuild -- | > ListFold ~ List/fold @@ -349,6 +352,7 @@ TextAppend a b >>= k = TextAppend (a >>= k) (b >>= k) List >>= _ = List ListLit a b >>= k = ListLit (fmap (>>= k) a) (fmap (>>= k) b) + ListAppend a b >>= k = ListAppend (a >>= k) (b >>= k) ListBuild >>= _ = ListBuild ListFold >>= _ = ListFold ListLength >>= _ = ListLength @@ -408,6 +412,7 @@ first k (TextAppend a b ) = TextAppend (first k a) (first k b) first _ List = List first k (ListLit a b ) = ListLit (fmap (first k) a) (fmap (first k) b) + first k (ListAppend a b ) = ListAppend (first k a) (first k b) first _ ListBuild = ListBuild first _ ListFold = ListFold first _ ListLength = ListLength @@ -565,40 +570,46 @@ -- | Builder corresponding to the @exprC3@ parser in "Dhall.Parser" buildExprC3 :: Buildable a => Expr s a -> Builder -buildExprC3 (BoolAnd a b) = buildExprC4 a <> " && " <> buildExprC3 b -buildExprC3 (Note _ b) = buildExprC3 b -buildExprC3 a = buildExprC4 a +buildExprC3 (ListAppend a b) = buildExprC4 a <> " # " <> buildExprC3 b +buildExprC3 (Note _ b) = buildExprC3 b +buildExprC3 a = buildExprC4 a -- | Builder corresponding to the @exprC4@ parser in "Dhall.Parser" buildExprC4 :: Buildable a => Expr s a -> Builder -buildExprC4 (Combine a b) = buildExprC5 a <> " ∧ " <> buildExprC4 b -buildExprC4 (Note _ b) = buildExprC4 b -buildExprC4 a = buildExprC5 a +buildExprC4 (BoolAnd a b) = buildExprC5 a <> " && " <> buildExprC4 b +buildExprC4 (Note _ b) = buildExprC4 b +buildExprC4 a = buildExprC5 a -- | Builder corresponding to the @exprC5@ parser in "Dhall.Parser" buildExprC5 :: Buildable a => Expr s a -> Builder -buildExprC5 (Prefer a b) = buildExprC6 a <> " ⫽ " <> buildExprC5 b -buildExprC5 (Note _ b) = buildExprC5 b -buildExprC5 a = buildExprC6 a +buildExprC5 (Combine a b) = buildExprC6 a <> " ∧ " <> buildExprC5 b +buildExprC5 (Note _ b) = buildExprC5 b +buildExprC5 a = buildExprC6 a -- | Builder corresponding to the @exprC6@ parser in "Dhall.Parser" buildExprC6 :: Buildable a => Expr s a -> Builder -buildExprC6 (NaturalTimes a b) = buildExprC7 a <> " * " <> buildExprC6 b -buildExprC6 (Note _ b) = buildExprC6 b -buildExprC6 a = buildExprC7 a +buildExprC6 (Prefer a b) = buildExprC7 a <> " ⫽ " <> buildExprC6 b +buildExprC6 (Note _ b) = buildExprC6 b +buildExprC6 a = buildExprC7 a -- | Builder corresponding to the @exprC7@ parser in "Dhall.Parser" buildExprC7 :: Buildable a => Expr s a -> Builder -buildExprC7 (BoolEQ a b) = buildExprC8 a <> " == " <> buildExprC7 b -buildExprC7 (Note _ b) = buildExprC7 b -buildExprC7 a = buildExprC8 a +buildExprC7 (NaturalTimes a b) = buildExprC8 a <> " * " <> buildExprC7 b +buildExprC7 (Note _ b) = buildExprC7 b +buildExprC7 a = buildExprC8 a -- | Builder corresponding to the @exprC8@ parser in "Dhall.Parser" buildExprC8 :: Buildable a => Expr s a -> Builder -buildExprC8 (BoolNE a b) = buildExprD a <> " != " <> buildExprC8 b +buildExprC8 (BoolEQ a b) = buildExprC9 a <> " == " <> buildExprC8 b buildExprC8 (Note _ b) = buildExprC8 b -buildExprC8 a = buildExprD a +buildExprC8 a = buildExprC9 a +-- | Builder corresponding to the @exprC9@ parser in "Dhall.Parser" +buildExprC9 :: Buildable a => Expr s a -> Builder +buildExprC9 (BoolNE a b) = buildExprD a <> " != " <> buildExprC9 b +buildExprC9 (Note _ b) = buildExprC9 b +buildExprC9 a = buildExprD a + -- | Builder corresponding to the @exprD@ parser in "Dhall.Parser" buildExprD :: Buildable a => Expr s a -> Builder buildExprD (App a b) = buildExprD a <> " " <> buildExprE b @@ -687,6 +698,8 @@ buildUnion a buildExprF (UnionLit a b c) = buildUnionLit a b c +buildExprF (ListLit Nothing b) = + "[" <> buildElems (Data.Vector.toList b) <> "]" buildExprF (Embed a) = build a buildExprF (Note _ b) = @@ -940,6 +953,10 @@ a' = fmap (shift d v) a b' = fmap (shift d v) b shift _ _ ListBuild = ListBuild +shift d v (ListAppend a b) = ListAppend a' b' + where + a' = shift d v a + b' = shift d v b shift _ _ ListFold = ListFold shift _ _ ListLength = ListLength shift _ _ ListHead = ListHead @@ -1079,6 +1096,10 @@ where a' = fmap (subst x e) a b' = fmap (subst x e) b +subst x e (ListAppend a b) = ListAppend a' b' + where + a' = subst x e a + b' = subst x e b subst _ _ ListBuild = ListBuild subst _ _ ListFold = ListFold subst _ _ ListLength = ListLength @@ -1129,38 +1150,67 @@ However, `normalize` will not fail if the expression is ill-typed and will leave ill-typed sub-expressions unevaluated. -} -normalize :: Expr s a -> Expr t a -normalize e = case e of +normalize :: Expr s a -> Expr t a +normalize = normalizeWith (const Nothing) + + +{-| Reduce an expression to its normal form, performing beta reduction and applying + any custom definitions. + + `normalizeWith` is designed to be used with function `typeWith`. The `typeWith` + function allows typing of Dhall functions in a custom typing context whereas + `normalizeWith` allows evaluating Dhall expressions in a custom context. + + To be more precise `normalizeWith` applies the given normalizer when it finds an + application term that it cannot reduce by other means. + + Note that the context used in normalization will determine the properties of normalization. + That is, if the functions in custom context are not total then the Dhall language, evaluated + with those functions is not total either. + +-} +normalizeWith :: Normalizer a -> Expr s a -> Expr t a +normalizeWith ctx e0 = loop (shift 0 "_" e0) + where + -- This is to avoid a `Show` constraint on the @a@ and @s@ in the type of + -- `loop`. In theory, this might change a failing repro case into + -- a successful one, but the risk of that is low enough to not warrant + -- the `Show` constraint. I care more about proving at the type level + -- that the @a@ and @s@ type parameters are never used + e'' = bimap (\_ -> ()) (\_ -> ()) e0 + + text = "NormalizeWith.loop (" <> Data.Text.pack (show e'') <> ")" + loop e = case e of Const k -> Const k Var v -> Var v Lam x _A b -> Lam x _A' b' where - _A' = normalize _A - b' = normalize b + _A' = loop _A + b' = loop b Pi x _A _B -> Pi x _A' _B' where - _A' = normalize _A - _B' = normalize _B - App f a -> case normalize f of - Lam x _A b -> normalize b'' -- Beta reduce + _A' = loop _A + _B' = loop _B + App f a -> case loop f of + Lam x _A b -> loop b'' -- Beta reduce where a' = shift 1 (V x 0) a b' = subst (V x 0) a' b b'' = shift (-1) (V x 0) b' f' -> case App f' a' of -- fold/build fusion for `List` - App (App ListBuild _) (App (App ListFold _) e') -> normalize e' - App (App ListFold _) (App (App ListBuild _) e') -> normalize e' + App (App ListBuild _) (App (App ListFold _) e') -> loop e' + App (App ListFold _) (App (App ListBuild _) e') -> loop e' -- fold/build fusion for `Natural` - App NaturalBuild (App NaturalFold e') -> normalize e' - App NaturalFold (App NaturalBuild e') -> normalize e' + App NaturalBuild (App NaturalFold e') -> loop e' + App NaturalFold (App NaturalBuild e') -> loop e' -- fold/build fusion for `Optional` - App (App OptionalBuild _) (App (App OptionalFold _) e') -> normalize e' - App (App OptionalFold _) (App (App OptionalBuild _) e') -> normalize e' + App (App OptionalBuild _) (App (App OptionalFold _) e') -> loop e' + App (App OptionalFold _) (App (App OptionalBuild _) e') -> loop e' App (App (App (App NaturalFold (NaturalLit n0)) _) succ') zero -> - normalize (go n0) + loop (go n0) where go !0 = zero go !n = App succ' (go (n - 1)) @@ -1169,7 +1219,7 @@ | otherwise -> App f' a' where labeled = - normalize (App (App (App k Natural) "Succ") "Zero") + loop (App (App (App k Natural) "Succ") "Zero") n = go 0 labeled where @@ -1192,7 +1242,7 @@ | check -> OptionalLit t k' | otherwise -> App f' a' where - labeled = normalize (App (App (App k (App Optional t)) "Just") "Nothing") + labeled = loop (App (App (App k (App Optional t)) "Just") "Nothing") k' = go labeled where @@ -1209,7 +1259,7 @@ | otherwise -> App f' a' where labeled = - normalize (App (App (App k (App List t)) "Cons") "Nil") + loop (App (App (App k (App List t)) "Cons") "Nil") k' cons nil = go labeled where @@ -1222,21 +1272,21 @@ go (Var "Nil") = True go _ = False App (App (App (App (App ListFold _) (ListLit _ xs)) _) cons) nil -> - normalize (Data.Vector.foldr cons' nil xs) + loop (Data.Vector.foldr cons' nil xs) where cons' y ys = App (App cons y) ys App (App ListLength _) (ListLit _ ys) -> NaturalLit (fromIntegral (Data.Vector.length ys)) App (App ListHead t) (ListLit _ ys) -> - normalize (OptionalLit t (Data.Vector.take 1 ys)) + loop (OptionalLit t (Data.Vector.take 1 ys)) App (App ListLast t) (ListLit _ ys) -> - normalize (OptionalLit t y) + loop (OptionalLit t y) where y = if Data.Vector.null ys then Data.Vector.empty else Data.Vector.singleton (Data.Vector.last ys) App (App ListIndexed t) (ListLit _ xs) -> - normalize (ListLit (Just t') (fmap adapt (Data.Vector.indexed xs))) + loop (ListLit (Just t') (fmap adapt (Data.Vector.indexed xs))) where t' = Record (Data.Map.fromList kts) where @@ -1249,21 +1299,23 @@ , ("value", x) ] App (App ListReverse t) (ListLit _ xs) -> - normalize (ListLit (Just t) (Data.Vector.reverse xs)) + loop (ListLit (Just t) (Data.Vector.reverse xs)) App (App (App (App (App OptionalFold _) (OptionalLit _ xs)) _) just) nothing -> - normalize (maybe nothing just' (toMaybe xs)) + loop (maybe nothing just' (toMaybe xs)) where just' y = App just y toMaybe = Data.Maybe.listToMaybe . Data.Vector.toList - _ -> App f' a' + _ -> case ctx (App f' a') of + Nothing -> App f' a' + Just app' -> loop app' where - a' = normalize a - Let f _ r b -> normalize b'' + a' = loop a + Let f _ r b -> loop b'' where r' = shift 1 (V f 0) r b' = subst (V f 0) r' b b'' = shift (-1) (V f 0) b' - Annot x _ -> normalize x + Annot x _ -> loop x Bool -> Bool BoolLit b -> BoolLit b BoolAnd x y -> @@ -1274,8 +1326,8 @@ _ -> BoolAnd x' y' _ -> BoolAnd x' y' where - x' = normalize x - y' = normalize y + x' = loop x + y' = loop y BoolOr x y -> case x' of BoolLit xn -> @@ -1284,8 +1336,8 @@ _ -> BoolOr x' y' _ -> BoolOr x' y' where - x' = normalize x - y' = normalize y + x' = loop x + y' = loop y BoolEQ x y -> case x' of BoolLit xn -> @@ -1294,8 +1346,8 @@ _ -> BoolEQ x' y' _ -> BoolEQ x' y' where - x' = normalize x - y' = normalize y + x' = loop x + y' = loop y BoolNE x y -> case x' of BoolLit xn -> @@ -1304,15 +1356,15 @@ _ -> BoolNE x' y' _ -> BoolNE x' y' where - x' = normalize x - y' = normalize y - BoolIf b true false -> case normalize b of + x' = loop x + y' = loop y + BoolIf b true false -> case loop b of BoolLit True -> true' BoolLit False -> false' b' -> BoolIf b' true' false' where - true' = normalize true - false' = normalize false + true' = loop true + false' = loop false Natural -> Natural NaturalLit n -> NaturalLit n NaturalFold -> NaturalFold @@ -1330,8 +1382,8 @@ _ -> NaturalPlus x' y' _ -> NaturalPlus x' y' where - x' = normalize x - y' = normalize y + x' = loop x + y' = loop y NaturalTimes x y -> case x' of NaturalLit xn -> @@ -1340,8 +1392,8 @@ _ -> NaturalTimes x' y' _ -> NaturalTimes x' y' where - x' = normalize x - y' = normalize y + x' = loop x + y' = loop y Integer -> Integer IntegerLit n -> IntegerLit n IntegerShow -> IntegerShow @@ -1358,13 +1410,23 @@ _ -> TextAppend x' y' _ -> TextAppend x' y' where - x' = normalize x - y' = normalize y + x' = loop x + y' = loop y List -> List ListLit t es -> ListLit t' es' where - t' = fmap normalize t - es' = fmap normalize es + t' = fmap loop t + es' = fmap loop es + ListAppend x y -> + case x' of + ListLit t xs -> + case y' of + ListLit _ ys -> ListLit t (xs <> ys) + _ -> ListAppend x' y' + _ -> ListAppend x' y' + where + x' = loop x + y' = loop y ListBuild -> ListBuild ListFold -> ListFold ListLength -> ListLength @@ -1375,76 +1437,79 @@ Optional -> Optional OptionalLit t es -> OptionalLit t' es' where - t' = normalize t - es' = fmap normalize es + t' = loop t + es' = fmap loop es OptionalFold -> OptionalFold OptionalBuild -> OptionalBuild Record kts -> Record kts' where - kts' = fmap normalize kts + kts' = fmap loop kts RecordLit kvs -> RecordLit kvs' where - kvs' = fmap normalize kvs + kvs' = fmap loop kvs Union kts -> Union kts' where - kts' = fmap normalize kts + kts' = fmap loop kts UnionLit k v kvs -> UnionLit k v' kvs' where - v' = normalize v - kvs' = fmap normalize kvs + v' = loop v + kvs' = fmap loop kvs Combine x0 y0 -> let combine x y = case x of RecordLit kvsX -> case y of RecordLit kvsY -> let kvs = Data.Map.unionWith combine kvsX kvsY - in RecordLit (fmap normalize kvs) + in RecordLit (fmap loop kvs) _ -> Combine x y _ -> Combine x y - in combine (normalize x0) (normalize y0) + in combine (loop x0) (loop y0) Prefer x y -> case x' of RecordLit kvsX -> case y' of RecordLit kvsY -> - RecordLit (fmap normalize (Data.Map.union kvsY kvsX)) + RecordLit (fmap loop (Data.Map.union kvsY kvsX)) _ -> Prefer x' y' _ -> Prefer x' y' where - x' = normalize x - y' = normalize y + x' = loop x + y' = loop y Merge x y t -> case x' of RecordLit kvsX -> case y' of UnionLit kY vY _ -> case Data.Map.lookup kY kvsX of - Just vX -> normalize (App vX vY) + Just vX -> loop (App vX vY) Nothing -> Merge x' y' t' _ -> Merge x' y' t' _ -> Merge x' y' t' where - x' = normalize x - y' = normalize y - t' = fmap normalize t + x' = loop x + y' = loop y + t' = fmap loop t Field r x -> - case normalize r of + case loop r of RecordLit kvs -> case Data.Map.lookup x kvs of - Just v -> normalize v - Nothing -> Field (RecordLit (fmap normalize kvs)) x + Just v -> loop v + Nothing -> Field (RecordLit (fmap loop kvs)) x r' -> Field r' x - Note _ e' -> normalize e' + Note _ e' -> loop e' Embed a -> Embed a - where - -- This is to avoid a `Show` constraint on the @a@ and @s@ in the type of - -- `normalize`. In theory, this might change a failing repro case into - -- a successful one, but the risk of that is low enough to not warrant - -- the `Show` constraint. I care more about proving at the type level - -- that the @a@ and @s@ type parameters are never used - e'' = bimap (\_ -> ()) (\_ -> ()) e - text = "normalize (" <> Data.Text.pack (show e'') <> ")" +-- | Use this to wrap you embedded functions (see `normalizeWith`) to make them +-- polymorphic enough to be used. +type Normalizer a = forall s. Expr s a -> Maybe (Expr s a) +-- | Check if an expression is in a normal form given a context of evaluation. +-- Unlike `isNormalized`, this will fully normalize and traverse through the expression. +-- +-- It is much more efficient to use `isNormalized`. +isNormalizedWith :: (Eq s, Eq a) => Normalizer a -> Expr s a -> Bool +isNormalizedWith ctx e = e == (normalizeWith ctx e) + + -- | Quickly check if an expression is in normal form isNormalized :: Expr s a -> Bool isNormalized e = case shift 0 "_" e of -- `shift` is a hack to delete `Note` @@ -1587,6 +1652,13 @@ _ -> True List -> True ListLit t es -> all isNormalized t && all isNormalized es + ListAppend x y -> isNormalized x && isNormalized y && + case x of + ListLit _ _ -> + case y of + ListLit _ _ -> False + _ -> True + _ -> True ListBuild -> True ListFold -> True ListLength -> True @@ -1636,28 +1708,28 @@ Note _ e' -> isNormalized e' Embed _ -> True -_ERROR :: Data.Text.Text +_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 (Data.Text.unpack [NeatInterpolation.text| -$_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/Gabriel439/Haskell-Dhall-Library/issues - -Please include the following text in your bug report: - -``` -$text -``` -|]) +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/Gabriel439/Haskell-Dhall-Library/issues " + , " " + , "Please include the following text in your bug report: " + , " " + , "``` " + , Data.Text.unpack text <> " " + , "``` " + ] ) buildVector :: (forall x . (a -> x -> x) -> x -> x) -> Vector a buildVector f = Data.Vector.reverse (Data.Vector.create (do diff --git a/src/Dhall/Import.hs b/src/Dhall/Import.hs --- a/src/Dhall/Import.hs +++ b/src/Dhall/Import.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wall #-} @@ -103,6 +102,7 @@ -- * Import exprFromPath , load + , loadWith , Cycle(..) , ReferentiallyOpaque(..) , Imported(..) @@ -150,7 +150,6 @@ import qualified Data.CaseInsensitive import qualified Data.List as List import qualified Data.Map.Strict as Map -import qualified Data.Text import qualified Data.Text.Encoding import qualified Data.Text.Lazy as Text import qualified Data.Text.Lazy.Builder as Builder @@ -158,10 +157,10 @@ import qualified Data.Vector import qualified Dhall.Core import qualified Dhall.Parser +import qualified Dhall.Context import qualified Dhall.TypeCheck import qualified Filesystem import qualified Filesystem.Path.CurrentOS -import qualified NeatInterpolation import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as HTTP import qualified Filesystem.Path.CurrentOS as Filesystem @@ -479,25 +478,25 @@ -} data InternalError = InternalError deriving (Typeable) -_ERROR :: Data.Text.Text +_ERROR :: String _ERROR = "\ESC[1;31mError\ESC[0m" instance Show InternalError where - show InternalError = Data.Text.unpack [NeatInterpolation.text| -$_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/Gabriel439/Haskell-Dhall-Library/issues - -Please include the following text in your bug report: - -``` -Header extraction failed even though the header type-checked -``` -|] + show InternalError = 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/Gabriel439/Haskell-Dhall-Library/issues " + , " " + , "Please include the following text in your bug report: " + , " " + , "``` " + , "Header extraction failed even though the header type-checked " + , "``` " + ] instance Exception InternalError @@ -674,7 +673,10 @@ -- | Load a `Path` as a \"static\" expression (with all imports resolved) loadStatic :: Path -> StateT Status IO (Expr Src X) -loadStatic path = do +loadStatic = loadStaticWith Dhall.Context.empty + +loadStaticWith :: Dhall.Context.Context (Expr Src X) -> Path -> StateT Status IO (Expr Src X) +loadStaticWith ctx path = do paths <- zoom stack State.get let local (Path (URL url _) _) = @@ -711,7 +713,8 @@ Nothing -> do let paths' = path:paths zoom stack (State.put paths') - expr'' <- fmap join (traverse loadStatic expr') + expr'' <- fmap join (traverse (loadStaticWith ctx) + expr') zoom stack (State.put paths) return expr'' return (expr'', False) @@ -725,7 +728,7 @@ -- have already been checked if cached then return () - else case Dhall.TypeCheck.typeOf expr of + else case Dhall.TypeCheck.typeWith ctx expr of Left err -> liftIO (throwIO (Imported (path:paths) err)) Right _ -> return () @@ -734,5 +737,11 @@ -- | Resolve all imports within an expression load :: Expr Src Path -> IO (Expr Src X) load expr = State.evalStateT (fmap join (traverse loadStatic expr)) status + where + status = Status [] Map.empty Nothing + +-- | Resolve all imports within an expression using a custom typing context +loadWith :: Dhall.Context.Context (Expr Src X) -> Expr Src Path -> IO (Expr Src X) +loadWith ctx expr = State.evalStateT (fmap join (traverse (loadStaticWith ctx) expr)) status where status = Status [] Map.empty Nothing diff --git a/src/Dhall/Parser.hs b/src/Dhall/Parser.hs --- a/src/Dhall/Parser.hs +++ b/src/Dhall/Parser.hs @@ -481,12 +481,13 @@ exprC0 = chain exprC1 (symbol "||") BoolOr exprC0 exprC1 = chain exprC2 (symbol "+" ) NaturalPlus exprC1 exprC2 = chain exprC3 (symbol "++") TextAppend exprC2 - exprC3 = chain exprC4 (symbol "&&") BoolAnd exprC3 - exprC4 = chain exprC5 combine Combine exprC4 - exprC5 = chain exprC6 prefer Prefer exprC5 - exprC6 = chain exprC7 (symbol "*" ) NaturalTimes exprC6 - exprC7 = chain exprC8 (symbol "==") BoolEQ exprC7 - exprC8 = chain (exprD embedded) (symbol "!=") BoolNE exprC8 + exprC3 = chain exprC4 (symbol "#" ) ListAppend exprC3 + exprC4 = chain exprC5 (symbol "&&") BoolAnd exprC4 + exprC5 = chain exprC6 combine Combine exprC5 + exprC6 = chain exprC7 prefer Prefer exprC6 + exprC7 = chain exprC8 (symbol "*" ) NaturalTimes exprC7 + exprC8 = chain exprC9 (symbol "==") BoolEQ exprC8 + exprC9 = chain (exprD embedded) (symbol "!=") BoolNE exprC9 -- We can't use left-recursion to define `exprD` otherwise the parser will -- loop infinitely. However, I'd still like to use left-recursion in the diff --git a/src/Dhall/Tutorial.hs b/src/Dhall/Tutorial.hs --- a/src/Dhall/Tutorial.hs +++ b/src/Dhall/Tutorial.hs @@ -26,6 +26,9 @@ -- * Functions -- $functions + -- * Compiler + -- $compiler + -- * Strings -- $strings @@ -113,6 +116,9 @@ -- ** @List@ -- $list + -- *** @(#)@ + -- $listAppend + -- *** @List/fold@ -- $listFold @@ -627,9 +633,56 @@ -- functions in Haskell. The only difference is that Dhall requires you to -- annotate the type of the function's input. -- --- We can test our @makeBools@ function directly from the command line. This --- library comes with a command-line executable program named @dhall@ that you --- can use to both type-check files and convert them to a normal form. Our +-- You can import this function into Haskell, too: +-- +-- >>> makeBools <- input auto "./makeBools" :: IO (Bool -> Vector Bool) +-- >>> makeBools True +-- [True,False,True,True] +-- +-- The reason this works is that there is an `Interpret` instance for simple +-- functions: +-- +-- > instance (Inject a, Interpret b) => Interpret (a -> b) +-- +-- Thanks to currying, this instance works for functions of multiple simple +-- arguments: +-- +-- >>> dhallAnd <- input auto "λ(x : Bool) → λ(y : Bool) → x && y" :: IO (Bool -> Bool -> Bool) +-- >>> dhallAnd True False +-- False +-- +-- However, you can't convert anything more complex than that like a polymorphic +-- or higher-order function). You will need to apply those functions to their +-- arguments within Dhall before converting their result to a Haskell value. +-- +-- Just like `Interpret`, you can derive `Inject` for user-defined data types: +-- +-- > {-# LANGUAGE DeriveAnyClass #-} +-- > {-# LANGUAGE DeriveGeneric #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > module Main where +-- > +-- > import Dhall +-- > +-- > data Example0 = Example0 { foo :: Bool, bar :: Bool } +-- > deriving (Generic, Inject) +-- > +-- > main = do +-- > f <- input auto "λ(r : { foo : Bool, bar : Bool }) → r.foo && r.bar" +-- > print (f (Example0 { foo = True, bar = False }) :: Bool) +-- > print (f (Example0 { foo = True, bar = True }) :: Bool) +-- +-- The above program prints: +-- +-- > False +-- > True + +-- $compiler +-- +-- We can also test our @makeBools@ function directly from the command line. +-- This library comes with a command-line executable program named @dhall@ that +-- you can use to both type-check files and convert them to a normal form. Our -- compiler takes a program on standard input and then prints the program's type -- to standard error followed by the program's normal form to standard output: -- @@ -655,9 +708,9 @@ -- -- > forall x . b -- ... is the same as this Haskell type -- --- The part where Dhall differs from Haskell is that you can also use @∀@/@forall@ --- to give names to non-@Type@ arguments (such as the first argument to --- @makeBools@). +-- The part where Dhall differs from Haskell is that you can also use +-- @∀@/@forall@ to give names to non-@Type@ arguments (such as the first +-- argument to @makeBools@). -- -- The second line of Dhall's output is our program's normal form: -- @@ -1817,6 +1870,31 @@ -- Also, every @List@ must end with a mandatory type annotation -- -- The built-in operations on @List@s are: + +-- $listAppend +-- +-- Example: +-- +-- > $ dhall +-- > [1, 2, 3] # [5, 6, 7] +-- > +-- > List Integer +-- > +-- > [1, 2, 3, 4, 5, 6] +-- +-- Type: +-- +-- > Γ ⊢ x : List a Γ ⊢ y : List a +-- > ───────────────────────────────── +-- > Γ ⊢ x # y : List a +-- +-- Rules: +-- +-- > ([] : List a) # xs = xs +-- > +-- > xs # ([] : List a) = xs +-- > +-- > (xs # ys) # zs = xs # (ys # zs) -- $listFold -- diff --git a/src/Dhall/TypeCheck.hs b/src/Dhall/TypeCheck.hs --- a/src/Dhall/TypeCheck.hs +++ b/src/Dhall/TypeCheck.hs @@ -1,3135 +1,3136 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wall #-} - --- | This module contains the logic for type checking Dhall code - -module Dhall.TypeCheck ( - -- * Type-checking - typeWith - , typeOf - - -- * Types - , X(..) - , TypeError(..) - , DetailedTypeError(..) - , TypeMessage(..) - ) where - -import Control.Exception (Exception) -import Data.Foldable (forM_, toList) -import Data.Monoid ((<>)) -import Data.Set (Set) -import Data.Text.Buildable (Buildable(..)) -import Data.Text.Lazy (Text) -import Data.Text.Lazy.Builder (Builder) -import Data.Traversable (forM) -import Data.Typeable (Typeable) -import Dhall.Core (Const(..), Expr(..), Var(..)) -import Dhall.Context (Context) - -import qualified Control.Monad.Trans.State.Strict as State -import qualified Data.Map -import qualified Data.Set -import qualified Data.Text -import qualified Data.Text.Lazy as Text -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Vector -import qualified Dhall.Context -import qualified Dhall.Core -import qualified NeatInterpolation - -axiom :: Const -> Either (TypeError s) Const -axiom Type = return Kind -axiom Kind = Left (TypeError Dhall.Context.empty (Const Kind) Untyped) - -rule :: Const -> Const -> Either () Const -rule Type Kind = Left () -rule Type Type = return Type -rule Kind Kind = return Kind -rule Kind Type = return Type - -match :: Var -> Var -> [(Text, Text)] -> Bool -match (V xL nL) (V xR nR) [] = - xL == xR && nL == nR -match (V xL 0 ) (V xR 0 ) ((xL', xR'):_ ) - | xL == xL' && xR == xR' = True -match (V xL nL) (V xR nR) ((xL', xR'):xs) = - match (V xL nL') (V xR nR') xs - where - nL' = if xL == xL' then nL - 1 else nL - nR' = if xR == xR' then nR - 1 else nR - -propEqual :: Expr s X -> Expr t X -> Bool -propEqual eL0 eR0 = - State.evalState - (go (Dhall.Core.normalize eL0) (Dhall.Core.normalize eR0)) - [] - where - go (Const Type) (Const Type) = return True - go (Const Kind) (Const Kind) = return True - go (Var vL) (Var vR) = do - ctx <- State.get - return (match vL vR ctx) - go (Pi xL tL bL) (Pi xR tR bR) = do - ctx <- State.get - eq1 <- go tL tR - if eq1 - then do - State.put ((xL, xR):ctx) - eq2 <- go bL bR - State.put ctx - return eq2 - else return False - go (App fL aL) (App fR aR) = do - b1 <- go fL fR - if b1 then go aL aR else return False - go Bool Bool = return True - go Natural Natural = return True - go Integer Integer = return True - go Double Double = return True - go Text Text = return True - go List List = return True - go Optional Optional = return True - go (Record ktsL0) (Record ktsR0) = do - let loop ((kL, tL):ktsL) ((kR, tR):ktsR) - | kL == kR = do - b <- go tL tR - if b - then loop ktsL ktsR - else return False - loop [] [] = return True - loop _ _ = return False - loop (Data.Map.toList ktsL0) (Data.Map.toList ktsR0) - go (Union ktsL0) (Union ktsR0) = do - let loop ((kL, tL):ktsL) ((kR, tR):ktsR) - | kL == kR = do - b <- go tL tR - if b - then loop ktsL ktsR - else return False - loop [] [] = return True - loop _ _ = return False - loop (Data.Map.toList ktsL0) (Data.Map.toList ktsR0) - go _ _ = return False - -{-| Type-check an expression and return the expression's type if type-checking - succeeds or an error if type-checking fails - - `typeWith` does not necessarily normalize the type since full normalization - is not necessary for just type-checking. If you actually care about the - returned type then you may want to `Dhall.Core.normalize` it afterwards. --} -typeWith :: Context (Expr s X) -> Expr s X -> Either (TypeError s) (Expr s X) -typeWith _ (Const c ) = do - fmap Const (axiom c) -typeWith ctx e@(Var (V x n) ) = do - case Dhall.Context.lookup x n ctx of - Nothing -> Left (TypeError ctx e UnboundVariable) - Just a -> return a -typeWith ctx (Lam x _A b ) = do - let ctx' = fmap (Dhall.Core.shift 1 (V x 0)) (Dhall.Context.insert x _A ctx) - _B <- typeWith ctx' b - let p = Pi x _A _B - _t <- typeWith ctx p - return p -typeWith ctx e@(Pi x _A _B ) = do - tA <- fmap Dhall.Core.normalize (typeWith ctx _A) - kA <- case tA of - Const k -> return k - _ -> Left (TypeError ctx e (InvalidInputType _A)) - - let ctx' = fmap (Dhall.Core.shift 1 (V x 0)) (Dhall.Context.insert x _A ctx) - tB <- fmap Dhall.Core.normalize (typeWith ctx' _B) - kB <- case tB of - Const k -> return k - _ -> Left (TypeError ctx' e (InvalidOutputType _B)) - - case rule kA kB of - Left () -> Left (TypeError ctx e (NoDependentTypes _A _B)) - Right k -> Right (Const k) -typeWith ctx e@(App f a ) = do - tf <- fmap Dhall.Core.normalize (typeWith ctx f) - (x, _A, _B) <- case tf of - Pi x _A _B -> return (x, _A, _B) - _ -> Left (TypeError ctx e (NotAFunction f tf)) - _A' <- typeWith ctx a - if propEqual _A _A' - then do - let a' = Dhall.Core.shift 1 (V x 0) a - let _B' = Dhall.Core.subst (V x 0) a' _B - let _B'' = Dhall.Core.shift (-1) (V x 0) _B' - return _B'' - else do - let nf_A = Dhall.Core.normalize _A - let nf_A' = Dhall.Core.normalize _A' - Left (TypeError ctx e (TypeMismatch f nf_A a nf_A')) -typeWith ctx e@(Let f mt r b ) = do - tR <- typeWith ctx r - ttR <- fmap Dhall.Core.normalize (typeWith ctx tR) - kR <- case ttR of - Const k -> return k - -- Don't bother to provide a `let`-specific version of this error - -- message because this should never happen anyway - _ -> Left (TypeError ctx e (InvalidInputType tR)) - - let ctx' = Dhall.Context.insert f tR ctx - tB <- typeWith ctx' b - ttB <- fmap Dhall.Core.normalize (typeWith ctx tB) - kB <- case ttB of - Const k -> return k - -- Don't bother to provide a `let`-specific version of this error - -- message because this should never happen anyway - _ -> Left (TypeError ctx e (InvalidOutputType tB)) - - case rule kR kB of - Left () -> Left (TypeError ctx e (NoDependentLet tR tB)) - Right _ -> return () - - case mt of - Nothing -> do - return () - Just t -> do - let nf_t = Dhall.Core.normalize t - let nf_tR = Dhall.Core.normalize tR - if propEqual nf_tR nf_t - then return () - else Left (TypeError ctx e (AnnotMismatch r nf_t nf_tR)) - - return tB -typeWith ctx e@(Annot x t ) = do - -- This is mainly just to check that `t` is not `Kind` - _ <- typeWith ctx t - - t' <- typeWith ctx x - if propEqual t t' - then do - return t - else do - let nf_t = Dhall.Core.normalize t - let nf_t' = Dhall.Core.normalize t' - Left (TypeError ctx e (AnnotMismatch x nf_t nf_t')) -typeWith _ Bool = do - return (Const Type) -typeWith _ (BoolLit _ ) = do - return Bool -typeWith ctx e@(BoolAnd l r ) = do - tl <- fmap Dhall.Core.normalize (typeWith ctx l) - case tl of - Bool -> return () - _ -> Left (TypeError ctx e (CantAnd l tl)) - - tr <- fmap Dhall.Core.normalize (typeWith ctx r) - case tr of - Bool -> return () - _ -> Left (TypeError ctx e (CantAnd r tr)) - - return Bool -typeWith ctx e@(BoolOr l r ) = do - tl <- fmap Dhall.Core.normalize (typeWith ctx l) - case tl of - Bool -> return () - _ -> Left (TypeError ctx e (CantOr l tl)) - - tr <- fmap Dhall.Core.normalize (typeWith ctx r) - case tr of - Bool -> return () - _ -> Left (TypeError ctx e (CantOr r tr)) - - return Bool -typeWith ctx e@(BoolEQ l r ) = do - tl <- fmap Dhall.Core.normalize (typeWith ctx l) - case tl of - Bool -> return () - _ -> Left (TypeError ctx e (CantEQ l tl)) - - tr <- fmap Dhall.Core.normalize (typeWith ctx r) - case tr of - Bool -> return () - _ -> Left (TypeError ctx e (CantEQ r tr)) - - return Bool -typeWith ctx e@(BoolNE l r ) = do - tl <- fmap Dhall.Core.normalize (typeWith ctx l) - case tl of - Bool -> return () - _ -> Left (TypeError ctx e (CantNE l tl)) - - tr <- fmap Dhall.Core.normalize (typeWith ctx r) - case tr of - Bool -> return () - _ -> Left (TypeError ctx e (CantNE r tr)) - - return Bool -typeWith ctx e@(BoolIf x y z ) = do - tx <- fmap Dhall.Core.normalize (typeWith ctx x) - case tx of - Bool -> return () - _ -> Left (TypeError ctx e (InvalidPredicate x tx)) - ty <- fmap Dhall.Core.normalize (typeWith ctx y ) - tty <- fmap Dhall.Core.normalize (typeWith ctx ty) - case tty of - Const Type -> return () - _ -> Left (TypeError ctx e (IfBranchMustBeTerm True y ty tty)) - - tz <- fmap Dhall.Core.normalize (typeWith ctx z) - ttz <- fmap Dhall.Core.normalize (typeWith ctx tz) - case ttz of - Const Type -> return () - _ -> Left (TypeError ctx e (IfBranchMustBeTerm False z tz ttz)) - - if propEqual ty tz - then return () - else Left (TypeError ctx e (IfBranchMismatch y z ty tz)) - return ty -typeWith _ Natural = do - return (Const Type) -typeWith _ (NaturalLit _ ) = do - return Natural -typeWith _ NaturalFold = do - return - (Pi "_" Natural - (Pi "natural" (Const Type) - (Pi "succ" (Pi "_" "natural" "natural") - (Pi "zero" "natural" "natural") ) ) ) -typeWith _ NaturalBuild = do - return - (Pi "_" - (Pi "natural" (Const Type) - (Pi "succ" (Pi "_" "natural" "natural") - (Pi "zero" "natural" "natural") ) ) - Natural ) -typeWith _ NaturalIsZero = do - return (Pi "_" Natural Bool) -typeWith _ NaturalEven = do - return (Pi "_" Natural Bool) -typeWith _ NaturalOdd = do - return (Pi "_" Natural Bool) -typeWith _ NaturalToInteger = do - return (Pi "_" Natural Integer) -typeWith _ NaturalShow = do - return (Pi "_" Natural Text) -typeWith ctx e@(NaturalPlus l r) = do - tl <- fmap Dhall.Core.normalize (typeWith ctx l) - case tl of - Natural -> return () - _ -> Left (TypeError ctx e (CantAdd l tl)) - - tr <- fmap Dhall.Core.normalize (typeWith ctx r) - case tr of - Natural -> return () - _ -> Left (TypeError ctx e (CantAdd r tr)) - return Natural -typeWith ctx e@(NaturalTimes l r) = do - tl <- fmap Dhall.Core.normalize (typeWith ctx l) - case tl of - Natural -> return () - _ -> Left (TypeError ctx e (CantMultiply l tl)) - - tr <- fmap Dhall.Core.normalize (typeWith ctx r) - case tr of - Natural -> return () - _ -> Left (TypeError ctx e (CantMultiply r tr)) - return Natural -typeWith _ Integer = do - return (Const Type) -typeWith _ (IntegerLit _ ) = do - return Integer -typeWith _ IntegerShow = do - return (Pi "_" Integer Text) -typeWith _ Double = do - return (Const Type) -typeWith _ (DoubleLit _ ) = do - return Double -typeWith _ DoubleShow = do - return (Pi "_" Double Text) -typeWith _ Text = do - return (Const Type) -typeWith _ (TextLit _ ) = do - return Text -typeWith ctx e@(TextAppend l r ) = do - tl <- fmap Dhall.Core.normalize (typeWith ctx l) - case tl of - Text -> return () - _ -> Left (TypeError ctx e (CantTextAppend l tl)) - - tr <- fmap Dhall.Core.normalize (typeWith ctx r) - case tr of - Text -> return () - _ -> Left (TypeError ctx e (CantTextAppend r tr)) - return Text -typeWith _ List = do - return (Pi "_" (Const Type) (Const Type)) -typeWith ctx e@(ListLit Nothing xs) = do - if Data.Vector.null xs - then Left (TypeError ctx e MissingListType) - else do - t <- typeWith ctx (Data.Vector.head xs) - s <- fmap Dhall.Core.normalize (typeWith ctx t) - case s of - Const Type -> return () - _ -> Left (TypeError ctx e (InvalidListType t)) - flip Data.Vector.imapM_ xs (\i x -> do - t' <- typeWith ctx x - if propEqual t t' - then return () - else do - let nf_t = Dhall.Core.normalize t - let nf_t' = Dhall.Core.normalize t' - let err = MismatchedListElements i nf_t x nf_t' - Left (TypeError ctx e err) ) - return (App List t) -typeWith ctx e@(ListLit (Just t ) xs) = do - s <- fmap Dhall.Core.normalize (typeWith ctx t) - case s of - Const Type -> return () - _ -> Left (TypeError ctx e (InvalidListType t)) - flip Data.Vector.imapM_ xs (\i x -> do - t' <- typeWith ctx x - if propEqual t t' - then return () - else do - let nf_t = Dhall.Core.normalize t - let nf_t' = Dhall.Core.normalize t' - Left (TypeError ctx e (InvalidListElement i nf_t x nf_t')) ) - return (App List t) -typeWith _ ListBuild = do - return - (Pi "a" (Const Type) - (Pi "_" - (Pi "list" (Const Type) - (Pi "cons" (Pi "_" "a" (Pi "_" "list" "list")) - (Pi "nil" "list" "list") ) ) - (App List "a") ) ) -typeWith _ ListFold = do - return - (Pi "a" (Const Type) - (Pi "_" (App List "a") - (Pi "list" (Const Type) - (Pi "cons" (Pi "_" "a" (Pi "_" "list" "list")) - (Pi "nil" "list" "list")) ) ) ) -typeWith _ ListLength = do - return (Pi "a" (Const Type) (Pi "_" (App List "a") Natural)) -typeWith _ ListHead = do - return (Pi "a" (Const Type) (Pi "_" (App List "a") (App Optional "a"))) -typeWith _ ListLast = do - return (Pi "a" (Const Type) (Pi "_" (App List "a") (App Optional "a"))) -typeWith _ ListIndexed = do - let kts = [("index", Natural), ("value", "a")] - return - (Pi "a" (Const Type) - (Pi "_" (App List "a") - (App List (Record (Data.Map.fromList kts))) ) ) -typeWith _ ListReverse = do - return (Pi "a" (Const Type) (Pi "_" (App List "a") (App List "a"))) -typeWith _ Optional = do - return (Pi "_" (Const Type) (Const Type)) -typeWith ctx e@(OptionalLit t xs) = do - s <- fmap Dhall.Core.normalize (typeWith ctx t) - case s of - Const Type -> return () - _ -> Left (TypeError ctx e (InvalidOptionalType t)) - let n = Data.Vector.length xs - if 2 <= n - then Left (TypeError ctx e (InvalidOptionalLiteral n)) - else return () - forM_ xs (\x -> do - t' <- typeWith ctx x - if propEqual t t' - then return () - else do - let nf_t = Dhall.Core.normalize t - let nf_t' = Dhall.Core.normalize t' - Left (TypeError ctx e (InvalidOptionalElement nf_t x nf_t')) ) - return (App Optional t) -typeWith _ OptionalFold = do - return - (Pi "a" (Const Type) - (Pi "_" (App Optional "a") - (Pi "optional" (Const Type) - (Pi "just" (Pi "_" "a" "optional") - (Pi "nothing" "optional" "optional") ) ) ) ) -typeWith _ OptionalBuild = do - return - (Pi "a" (Const Type) - (Pi "_" f (App Optional "a") ) ) - where f = Pi "optional" (Const Type) - (Pi "just" (Pi "_" "a" "optional") - (Pi "nothing" "optional" "optional") ) -typeWith ctx e@(Record kts ) = do - let process (k, t) = do - s <- fmap Dhall.Core.normalize (typeWith ctx t) - case s of - Const Type -> return () - _ -> Left (TypeError ctx e (InvalidFieldType k t)) - mapM_ process (Data.Map.toList kts) - return (Const Type) -typeWith ctx e@(RecordLit kvs ) = do - let process (k, v) = do - t <- typeWith ctx v - s <- fmap Dhall.Core.normalize (typeWith ctx t) - case s of - Const Type -> return () - _ -> Left (TypeError ctx e (InvalidField k v)) - return (k, t) - kts <- mapM process (Data.Map.toAscList kvs) - return (Record (Data.Map.fromAscList kts)) -typeWith ctx e@(Union kts ) = do - let process (k, t) = do - s <- fmap Dhall.Core.normalize (typeWith ctx t) - case s of - Const Type -> return () - _ -> Left (TypeError ctx e (InvalidAlternativeType k t)) - mapM_ process (Data.Map.toList kts) - return (Const Type) -typeWith ctx e@(UnionLit k v kts) = do - case Data.Map.lookup k kts of - Just _ -> Left (TypeError ctx e (DuplicateAlternative k)) - Nothing -> return () - t <- typeWith ctx v - let union = Union (Data.Map.insert k t kts) - _ <- typeWith ctx union - return union -typeWith ctx e@(Combine kvsX kvsY) = do - tKvsX <- fmap Dhall.Core.normalize (typeWith ctx kvsX) - ktsX <- case tKvsX of - Record kts -> return kts - _ -> Left (TypeError ctx e (MustCombineARecord '∧' kvsX tKvsX)) - - tKvsY <- fmap Dhall.Core.normalize (typeWith ctx kvsY) - ktsY <- case tKvsY of - Record kts -> return kts - _ -> Left (TypeError ctx e (MustCombineARecord '∧' kvsY tKvsY)) - - let combineTypes ktsL ktsR = do - let ks = - Data.Set.union (Data.Map.keysSet ktsL) (Data.Map.keysSet ktsR) - kts <- forM (toList ks) (\k -> do - case (Data.Map.lookup k ktsL, Data.Map.lookup k ktsR) of - (Just (Record ktsL'), Just (Record ktsR')) -> do - t <- combineTypes ktsL' ktsR' - return (k, t) - (Nothing, Just t) -> do - return (k, t) - (Just t, Nothing) -> do - return (k, t) - _ -> do - Left (TypeError ctx e (FieldCollision k)) ) - return (Record (Data.Map.fromList kts)) - - combineTypes ktsX ktsY -typeWith ctx e@(Prefer kvsX kvsY) = do - tKvsX <- fmap Dhall.Core.normalize (typeWith ctx kvsX) - ktsX <- case tKvsX of - Record kts -> return kts - _ -> Left (TypeError ctx e (MustCombineARecord '⫽' kvsX tKvsX)) - - tKvsY <- fmap Dhall.Core.normalize (typeWith ctx kvsY) - ktsY <- case tKvsY of - Record kts -> return kts - _ -> Left (TypeError ctx e (MustCombineARecord '⫽' kvsY tKvsY)) - return (Record (Data.Map.union ktsY ktsX)) -typeWith ctx e@(Merge kvsX kvsY (Just t)) = do - tKvsX <- fmap Dhall.Core.normalize (typeWith ctx kvsX) - ktsX <- case tKvsX of - Record kts -> return kts - _ -> Left (TypeError ctx e (MustMergeARecord kvsX tKvsX)) - let ksX = Data.Map.keysSet ktsX - - tKvsY <- fmap Dhall.Core.normalize (typeWith ctx kvsY) - ktsY <- case tKvsY of - Union kts -> return kts - _ -> Left (TypeError ctx e (MustMergeUnion kvsY tKvsY)) - let ksY = Data.Map.keysSet ktsY - - let diffX = Data.Set.difference ksX ksY - let diffY = Data.Set.difference ksY ksX - - if Data.Set.null diffX - then return () - else Left (TypeError ctx e (UnusedHandler diffX)) - - let process (kY, tY) = do - case Data.Map.lookup kY ktsX of - Nothing -> Left (TypeError ctx e (MissingHandler diffY)) - Just tX -> - case tX of - Pi _ tY' t' -> do - if propEqual tY tY' - then return () - else Left (TypeError ctx e (HandlerInputTypeMismatch kY tY tY')) - if propEqual t t' - then return () - else Left (TypeError ctx e (InvalidHandlerOutputType kY t t')) - _ -> Left (TypeError ctx e (HandlerNotAFunction kY tX)) - mapM_ process (Data.Map.toList ktsY) - return t -typeWith ctx e@(Merge kvsX kvsY Nothing) = do - tKvsX <- fmap Dhall.Core.normalize (typeWith ctx kvsX) - ktsX <- case tKvsX of - Record kts -> return kts - _ -> Left (TypeError ctx e (MustMergeARecord kvsX tKvsX)) - let ksX = Data.Map.keysSet ktsX - - tKvsY <- fmap Dhall.Core.normalize (typeWith ctx kvsY) - ktsY <- case tKvsY of - Union kts -> return kts - _ -> Left (TypeError ctx e (MustMergeUnion kvsY tKvsY)) - let ksY = Data.Map.keysSet ktsY - - let diffX = Data.Set.difference ksX ksY - let diffY = Data.Set.difference ksY ksX - - if Data.Set.null diffX - then return () - else Left (TypeError ctx e (UnusedHandler diffX)) - - (kX, t) <- case Data.Map.assocs ktsX of - [] -> Left (TypeError ctx e MissingMergeType) - (kX, Pi _ _ t):_ -> return (kX, t) - (kX, tX ):_ -> Left (TypeError ctx e (HandlerNotAFunction kX tX)) - let process (kY, tY) = do - case Data.Map.lookup kY ktsX of - Nothing -> Left (TypeError ctx e (MissingHandler diffY)) - Just tX -> - case tX of - Pi _ tY' t' -> do - if propEqual tY tY' - then return () - else Left (TypeError ctx e (HandlerInputTypeMismatch kY tY tY')) - if propEqual t t' - then return () - else Left (TypeError ctx e (HandlerOutputTypeMismatch kX t kY t')) - _ -> Left (TypeError ctx e (HandlerNotAFunction kY tX)) - mapM_ process (Data.Map.toList ktsY) - return t -typeWith ctx e@(Field r x ) = do - t <- fmap Dhall.Core.normalize (typeWith ctx r) - case t of - Record kts -> - case Data.Map.lookup x kts of - Just t' -> return t' - Nothing -> Left (TypeError ctx e (MissingField x t)) - _ -> Left (TypeError ctx e (NotARecord x r t)) -typeWith ctx (Note s e' ) = case typeWith ctx e' of - Left (TypeError ctx' (Note s' e'') m) -> Left (TypeError ctx' (Note s' e'') m) - Left (TypeError ctx' e'' m) -> Left (TypeError ctx' (Note s e'') m) - Right r -> Right r -typeWith _ (Embed p ) = do - absurd p - -{-| `typeOf` is the same as `typeWith` with an empty context, meaning that the - expression must be closed (i.e. no free variables), otherwise type-checking - will fail. --} -typeOf :: Expr s X -> Either (TypeError s) (Expr s X) -typeOf = typeWith Dhall.Context.empty - --- | Like `Data.Void.Void`, except with a shorter inferred type -newtype X = X { absurd :: forall a . a } - -instance Show X where - show = absurd - -instance Eq X where - _ == _ = True - -instance Buildable X where - build = absurd - --- | The specific type error -data TypeMessage s - = UnboundVariable - | InvalidInputType (Expr s X) - | InvalidOutputType (Expr s X) - | NotAFunction (Expr s X) (Expr s X) - | TypeMismatch (Expr s X) (Expr s X) (Expr s X) (Expr s X) - | AnnotMismatch (Expr s X) (Expr s X) (Expr s X) - | Untyped - | MissingListType - | MismatchedListElements Int (Expr s X) (Expr s X) (Expr s X) - | InvalidListElement Int (Expr s X) (Expr s X) (Expr s X) - | InvalidListType (Expr s X) - | InvalidOptionalElement (Expr s X) (Expr s X) (Expr s X) - | InvalidOptionalLiteral Int - | InvalidOptionalType (Expr s X) - | InvalidPredicate (Expr s X) (Expr s X) - | IfBranchMismatch (Expr s X) (Expr s X) (Expr s X) (Expr s X) - | IfBranchMustBeTerm Bool (Expr s X) (Expr s X) (Expr s X) - | InvalidField Text (Expr s X) - | InvalidFieldType Text (Expr s X) - | InvalidAlternative Text (Expr s X) - | InvalidAlternativeType Text (Expr s X) - | DuplicateAlternative Text - | MustCombineARecord Char (Expr s X) (Expr s X) - | FieldCollision Text - | MustMergeARecord (Expr s X) (Expr s X) - | MustMergeUnion (Expr s X) (Expr s X) - | UnusedHandler (Set Text) - | MissingHandler (Set Text) - | HandlerInputTypeMismatch Text (Expr s X) (Expr s X) - | HandlerOutputTypeMismatch Text (Expr s X) Text (Expr s X) - | InvalidHandlerOutputType Text (Expr s X) (Expr s X) - | MissingMergeType - | HandlerNotAFunction Text (Expr s X) - | NotARecord Text (Expr s X) (Expr s X) - | MissingField Text (Expr s X) - | CantAnd (Expr s X) (Expr s X) - | CantOr (Expr s X) (Expr s X) - | CantEQ (Expr s X) (Expr s X) - | CantNE (Expr s X) (Expr s X) - | CantTextAppend (Expr s X) (Expr s X) - | CantAdd (Expr s X) (Expr s X) - | CantMultiply (Expr s X) (Expr s X) - | NoDependentLet (Expr s X) (Expr s X) - | NoDependentTypes (Expr s X) (Expr s X) - deriving (Show) - -shortTypeMessage :: TypeMessage s -> Builder -shortTypeMessage msg = - "\ESC[1;31mError\ESC[0m: " <> build short <> "\n" - where - ErrorMessages {..} = prettyTypeMessage msg - -longTypeMessage :: TypeMessage s -> Builder -longTypeMessage msg = - "\ESC[1;31mError\ESC[0m: " <> build short <> "\n" - <> "\n" - <> long - where - ErrorMessages {..} = prettyTypeMessage msg - -data ErrorMessages = ErrorMessages - { short :: Builder - -- ^ Default succinct 1-line explanation of what went wrong - , long :: Builder - -- ^ Longer and more detailed explanation of the error - } - -_NOT :: Data.Text.Text -_NOT = "\ESC[1mnot\ESC[0m" - -prettyTypeMessage :: TypeMessage s -> ErrorMessages -prettyTypeMessage UnboundVariable = ErrorMessages {..} - where - short = "Unbound variable" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: Expressions can only reference previously introduced (i.e. "bound") -variables that are still "in scope" - -For example, the following valid expressions introduce a "bound" variable named -❰x❱: - - - ┌─────────────────┐ - │ λ(x : Bool) → x │ Anonymous functions introduce "bound" variables - └─────────────────┘ - ⇧ - This is the bound variable - - - ┌─────────────────┐ - │ let x = 1 in x │ ❰let❱ expressions introduce "bound" variables - └─────────────────┘ - ⇧ - This is the bound variable - - -However, the following expressions are not valid because they all reference a -variable that has not been introduced yet (i.e. an "unbound" variable): - - - ┌─────────────────┐ - │ λ(x : Bool) → y │ The variable ❰y❱ hasn't been introduced yet - └─────────────────┘ - ⇧ - This is the unbound variable - - - ┌──────────────────────────┐ - │ (let x = True in x) && x │ ❰x❱ is undefined outside the parentheses - └──────────────────────────┘ - ⇧ - This is the unbound variable - - - ┌────────────────┐ - │ let x = x in x │ The definition for ❰x❱ cannot reference itself - └────────────────┘ - ⇧ - This is the unbound variable - - -Some common reasons why you might get this error: - -● You misspell a variable name, like this: - - - ┌────────────────────────────────────────────────────┐ - │ λ(empty : Bool) → if emty then "Empty" else "Full" │ - └────────────────────────────────────────────────────┘ - ⇧ - Typo - - -● You misspell a reserved identifier, like this: - - - ┌──────────────────────────┐ - │ foral (a : Type) → a → a │ - └──────────────────────────┘ - ⇧ - Typo - - -● You tried to define a recursive value, like this: - - - ┌─────────────────────┐ - │ let x = x + +1 in x │ - └─────────────────────┘ - ⇧ - Recursive definitions are not allowed - - -● You accidentally forgot a ❰λ❱ or ❰∀❱/❰forall❱ - - - Unbound variable - ⇩ - ┌─────────────────┐ - │ (x : Bool) → x │ - └─────────────────┘ - ⇧ - A ❰λ❱ here would transform this into a valid anonymous function - - - Unbound variable - ⇩ - ┌────────────────────┐ - │ (x : Bool) → Bool │ - └────────────────────┘ - ⇧ - A ❰∀❱ or ❰forall❱ here would transform this into a valid function type -|] - -prettyTypeMessage (InvalidInputType expr) = ErrorMessages {..} - where - short = "Invalid function input" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: A function can accept an input "term" that has a given "type", like -this: - - - This is the input term that the function accepts - ⇩ - ┌───────────────────────┐ - │ ∀(x : Natural) → Bool │ This is the type of a function that accepts an - └───────────────────────┘ input term named ❰x❱ that has type ❰Natural❱ - ⇧ - This is the type of the input term - - - ┌────────────────┐ - │ Bool → Integer │ This is the type of a function that accepts an anonymous - └────────────────┘ input term that has type ❰Bool❱ - ⇧ - This is the type of the input term - - -... or a function can accept an input "type" that has a given "kind", like this: - - - This is the input type that the function accepts - ⇩ - ┌────────────────────┐ - │ ∀(a : Type) → Type │ This is the type of a function that accepts an input - └────────────────────┘ type named ❰a❱ that has kind ❰Type❱ - ⇧ - This is the kind of the input type - - - ┌──────────────────────┐ - │ (Type → Type) → Type │ This is the type of a function that accepts an - └──────────────────────┘ anonymous input type that has kind ❰Type → Type❱ - ⇧ - This is the kind of the input type - - -Other function inputs are $_NOT valid, like this: - - - ┌──────────────┐ - │ ∀(x : 1) → x │ ❰1❱ is a "term" and not a "type" nor a "kind" so ❰x❱ - └──────────────┘ cannot have "type" ❰1❱ or "kind" ❰1❱ - ⇧ - This is not a type or kind - - - ┌──────────┐ - │ True → x │ ❰True❱ is a "term" and not a "type" nor a "kind" so the - └──────────┘ anonymous input cannot have "type" ❰True❱ or "kind" ❰True❱ - ⇧ - This is not a type or kind - - -You annotated a function input with the following expression: - -↳ $txt - -... which is neither a type nor a kind -|] - where - txt = Text.toStrict (Dhall.Core.pretty expr) - -prettyTypeMessage (InvalidOutputType expr) = ErrorMessages {..} - where - short = "Invalid function output" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: A function can return an output "term" that has a given "type", -like this: - - - ┌────────────────────┐ - │ ∀(x : Text) → Bool │ This is the type of a function that returns an - └────────────────────┘ output term that has type ❰Bool❱ - ⇧ - This is the type of the output term - - - ┌────────────────┐ - │ Bool → Integer │ This is the type of a function that returns an output - └────────────────┘ term that has type ❰Int❱ - ⇧ - This is the type of the output term - - -... or a function can return an output "type" that has a given "kind", like -this: - - ┌────────────────────┐ - │ ∀(a : Type) → Type │ This is the type of a function that returns an - └────────────────────┘ output type that has kind ❰Type❱ - ⇧ - This is the kind of the output type - - - ┌──────────────────────┐ - │ (Type → Type) → Type │ This is the type of a function that returns an - └──────────────────────┘ output type that has kind ❰Type❱ - ⇧ - This is the kind of the output type - - -Other outputs are $_NOT valid, like this: - - - ┌─────────────────┐ - │ ∀(x : Bool) → x │ ❰x❱ is a "term" and not a "type" nor a "kind" so the - └─────────────────┘ output cannot have "type" ❰x❱ or "kind" ❰x❱ - ⇧ - This is not a type or kind - - - ┌─────────────┐ - │ Text → True │ ❰True❱ is a "term" and not a "type" nor a "kind" so the - └─────────────┘ output cannot have "type" ❰True❱ or "kind" ❰True❱ - ⇧ - This is not a type or kind - - -Some common reasons why you might get this error: - -● You use ❰∀❱ instead of ❰λ❱ by mistake, like this: - - - ┌────────────────┐ - │ ∀(x: Bool) → x │ - └────────────────┘ - ⇧ - Using ❰λ❱ here instead of ❰∀❱ would transform this into a valid function - - -──────────────────────────────────────────────────────────────────────────────── - -You specified that your function outputs a: - -↳ $txt - -... which is neither a type nor a kind: -|] - where - txt = Text.toStrict (Dhall.Core.pretty expr) - -prettyTypeMessage (NotAFunction expr0 expr1) = ErrorMessages {..} - where - short = "Not a function" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: Expressions separated by whitespace denote function application, -like this: - - - ┌─────┐ - │ f x │ This denotes the function ❰f❱ applied to an argument named ❰x❱ - └─────┘ - - -A function is a term that has type ❰a → b❱ for some ❰a❱ or ❰b❱. For example, -the following expressions are all functions because they have a function type: - - - The function's input type is ❰Bool❱ - ⇩ - ┌───────────────────────────────┐ - │ λ(x : Bool) → x : Bool → Bool │ User-defined anonymous function - └───────────────────────────────┘ - ⇧ - The function's output type is ❰Bool❱ - - - The function's input type is ❰Natural❱ - ⇩ - ┌───────────────────────────────┐ - │ Natural/even : Natural → Bool │ Built-in function - └───────────────────────────────┘ - ⇧ - The function's output type is ❰Bool❱ - - - The function's input kind is ❰Type❱ - ⇩ - ┌───────────────────────────────┐ - │ λ(a : Type) → a : Type → Type │ Type-level functions are still functions - └───────────────────────────────┘ - ⇧ - The function's output kind is ❰Type❱ - - - The function's input kind is ❰Type❱ - ⇩ - ┌────────────────────┐ - │ List : Type → Type │ Built-in type-level function - └────────────────────┘ - ⇧ - The function's output kind is ❰Type❱ - - - Function's input has kind ❰Type❱ - ⇩ - ┌─────────────────────────────────────────────────┐ - │ List/head : ∀(a : Type) → (List a → Optional a) │ A function can return - └─────────────────────────────────────────────────┘ another function - ⇧ - Function's output has type ❰List a → Optional a❱ - - - The function's input type is ❰List Text❱ - ⇩ - ┌────────────────────────────────────────────┐ - │ List/head Text : List Text → Optional Text │ A function applied to an - └────────────────────────────────────────────┘ argument can be a function - ⇧ - The function's output type is ❰Optional Text❱ - - -An expression is not a function if the expression's type is not of the form -❰a → b❱. For example, these are $_NOT functions: - - - ┌─────────────┐ - │ 1 : Integer │ ❰1❱ is not a function because ❰Integer❱ is not the type of - └─────────────┘ a function - - - ┌────────────────────────┐ - │ Natural/even +2 : Bool │ ❰Natural/even +2❱ is not a function because - └────────────────────────┘ ❰Bool❱ is not the type of a function - - - ┌──────────────────┐ - │ List Text : Type │ ❰List Text❱ is not a function because ❰Type❱ is not - └──────────────────┘ the type of a function - - -Some common reasons why you might get this error: - -● You tried to add two ❰Integer❱s without a space around the ❰+❱, like this: - - - ┌─────┐ - │ 2+2 │ - └─────┘ - - - The above code is parsed as: - - - ┌────────┐ - │ 2 (+2) │ - └────────┘ - ⇧ - The compiler thinks that this ❰2❱ is a function whose argument is ❰+2❱ - - - This is because the ❰+❱ symbol has two meanings: you use ❰+❱ to add two - numbers, but you also can prefix ❰Integer❱ literals with a ❰+❱ to turn them - into ❰Natural❱ literals (like ❰+2❱) - - To fix the code, you need to put spaces around the ❰+❱ and also prefix each - ❰2❱ with a ❰+❱, like this: - - - ┌─────────┐ - │ +2 + +2 │ - └─────────┘ - - - You can only add ❰Natural❱ numbers, which is why you must also change each - ❰2❱ to ❰+2❱ - -──────────────────────────────────────────────────────────────────────────────── - -You tried to use the following expression as a function: - -↳ $txt0 - -... but this expression's type is: - -↳ $txt1 - -... which is not a function type -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty expr1) - -prettyTypeMessage (TypeMismatch expr0 expr1 expr2 expr3) = ErrorMessages {..} - where - short = "Wrong type of function argument" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: Every function declares what type or kind of argument to accept - -For example: - - - ┌───────────────────────────────┐ - │ λ(x : Bool) → x : Bool → Bool │ This anonymous function only accepts - └───────────────────────────────┘ arguments that have type ❰Bool❱ - ⇧ - The function's input type - - - ┌───────────────────────────────┐ - │ Natural/even : Natural → Bool │ This built-in function only accepts - └───────────────────────────────┘ arguments that have type ❰Natural❱ - ⇧ - The function's input type - - - ┌───────────────────────────────┐ - │ λ(a : Type) → a : Type → Type │ This anonymous function only accepts - └───────────────────────────────┘ arguments that have kind ❰Type❱ - ⇧ - The function's input kind - - - ┌────────────────────┐ - │ List : Type → Type │ This built-in function only accepts arguments that - └────────────────────┘ have kind ❰Type❱ - ⇧ - The function's input kind - - -For example, the following expressions are valid: - - - ┌────────────────────────┐ - │ (λ(x : Bool) → x) True │ ❰True❱ has type ❰Bool❱, which matches the type - └────────────────────────┘ of argument that the anonymous function accepts - - - ┌─────────────────┐ - │ Natural/even +2 │ ❰+2❱ has type ❰Natural❱, which matches the type of - └─────────────────┘ argument that the ❰Natural/even❱ function accepts, - - - ┌────────────────────────┐ - │ (λ(a : Type) → a) Bool │ ❰Bool❱ has kind ❰Type❱, which matches the kind - └────────────────────────┘ of argument that the anonymous function accepts - - - ┌───────────┐ - │ List Text │ ❰Text❱ has kind ❰Type❱, which matches the kind of argument - └───────────┘ that that the ❰List❱ function accepts - - -However, you can $_NOT apply a function to the wrong type or kind of argument - -For example, the following expressions are not valid: - - - ┌───────────────────────┐ - │ (λ(x : Bool) → x) "A" │ ❰"A"❱ has type ❰Text❱, but the anonymous function - └───────────────────────┘ expects an argument that has type ❰Bool❱ - - - ┌──────────────────┐ - │ Natural/even "A" │ ❰"A"❱ has type ❰Text❱, but the ❰Natural/even❱ function - └──────────────────┘ expects an argument that has type ❰Natural❱ - - - ┌────────────────────────┐ - │ (λ(a : Type) → a) True │ ❰True❱ has type ❰Bool❱, but the anonymous - └────────────────────────┘ function expects an argument of kind ❰Type❱ - - - ┌────────┐ - │ List 1 │ ❰1❱ has type ❰Integer❱, but the ❰List❱ function expects an - └────────┘ argument that has kind ❰Type❱ - - -Some common reasons why you might get this error: - -● You omit a function argument by mistake: - - - ┌───────────────────────┐ - │ List/head [1, 2, 3] │ - └───────────────────────┘ - ⇧ - ❰List/head❱ is missing the first argument, - which should be: ❰Integer❱ - - -● You supply an ❰Integer❱ literal to a function that expects a ❰Natural❱ - - - ┌────────────────┐ - │ Natural/even 2 │ - └────────────────┘ - ⇧ - This should be ❰+2❱ - - -──────────────────────────────────────────────────────────────────────────────── - -You tried to invoke the following function: - -↳ $txt0 - -... which expects an argument of type or kind: - -↳ $txt1 - -... on the following argument: - -↳ $txt2 - -... which has a different type or kind: - -↳ $txt3 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty expr1) - txt2 = Text.toStrict (Dhall.Core.pretty expr2) - txt3 = Text.toStrict (Dhall.Core.pretty expr3) - -prettyTypeMessage (AnnotMismatch expr0 expr1 expr2) = ErrorMessages {..} - where - short = "Expression doesn't match annotation" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: You can annotate an expression with its type or kind using the -❰:❱ symbol, like this: - - - ┌───────┐ - │ x : t │ ❰x❱ is an expression and ❰t❱ is the annotated type or kind of ❰x❱ - └───────┘ - -The type checker verifies that the expression's type or kind matches the -provided annotation - -For example, all of the following are valid annotations that the type checker -accepts: - - - ┌─────────────┐ - │ 1 : Integer │ ❰1❱ is an expression that has type ❰Integer❱, so the type - └─────────────┘ checker accepts the annotation - - - ┌────────────────────────┐ - │ Natural/even +2 : Bool │ ❰Natural/even +2❱ has type ❰Bool❱, so the type - └────────────────────────┘ checker accepts the annotation - - - ┌────────────────────┐ - │ List : Type → Type │ ❰List❱ is an expression that has kind ❰Type → Type❱, - └────────────────────┘ so the type checker accepts the annotation - - - ┌──────────────────┐ - │ List Text : Type │ ❰List Text❱ is an expression that has kind ❰Type❱, so - └──────────────────┘ the type checker accepts the annotation - - -However, the following annotations are $_NOT valid and the type checker will -reject them: - - - ┌──────────┐ - │ 1 : Text │ The type checker rejects this because ❰1❱ does not have type - └──────────┘ ❰Text❱ - - - ┌─────────────┐ - │ List : Type │ ❰List❱ does not have kind ❰Type❱ - └─────────────┘ - - -Some common reasons why you might get this error: - -● The Haskell Dhall interpreter implicitly inserts a top-level annotation - matching the expected type - - For example, if you run the following Haskell code: - - - ┌───────────────────────────────┐ - │ >>> input auto "1" :: IO Text │ - └───────────────────────────────┘ - - - ... then the interpreter will actually type check the following annotated - expression: - - - ┌──────────┐ - │ 1 : Text │ - └──────────┘ - - - ... and then type-checking will fail - -──────────────────────────────────────────────────────────────────────────────── - -You or the interpreter annotated this expression: - -↳ $txt0 - -... with this type or kind: - -↳ $txt1 - -... but the inferred type or kind of the expression is actually: - -↳ $txt2 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty expr1) - txt2 = Text.toStrict (Dhall.Core.pretty expr2) - -prettyTypeMessage Untyped = ErrorMessages {..} - where - short = "❰Kind❱ has no type or kind" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: There are four levels of expressions that form a heirarchy: - -● terms -● types -● kinds -● sorts - -The following example illustrates this heirarchy: - - ┌────────────────────────────┐ - │ "ABC" : Text : Type : Kind │ - └────────────────────────────┘ - ⇧ ⇧ ⇧ ⇧ - term type kind sort - -There is nothing above ❰Kind❱ in this hierarchy, so if you try to type check any -expression containing ❰Kind❱ anywhere in the expression then type checking fails - -Some common reasons why you might get this error: - -● You supplied a kind where a type was expected - - For example, the following expression will fail to type check: - - ┌────────────────┐ - │ [] : List Type │ - └────────────────┘ - ⇧ - ❰Type❱ is a kind, not a type -|] - -prettyTypeMessage (InvalidPredicate expr0 expr1) = ErrorMessages {..} - where - short = "Invalid predicate for ❰if❱" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: Every ❰if❱ expression begins with a predicate which must have type -❰Bool❱ - -For example, these are valid ❰if❱ expressions: - - - ┌──────────────────────────────┐ - │ if True then "Yes" else "No" │ - └──────────────────────────────┘ - ⇧ - Predicate - - - ┌─────────────────────────────────────────┐ - │ λ(x : Bool) → if x then False else True │ - └─────────────────────────────────────────┘ - ⇧ - Predicate - - -... but these are $_NOT valid ❰if❱ expressions: - - - ┌───────────────────────────┐ - │ if 0 then "Yes" else "No" │ ❰0❱ does not have type ❰Bool❱ - └───────────────────────────┘ - - - ┌────────────────────────────┐ - │ if "" then False else True │ ❰""❱ does not have type ❰Bool❱ - └────────────────────────────┘ - - -Some common reasons why you might get this error: - -● You might be used to other programming languages that accept predicates other - than ❰Bool❱ - - For example, some languages permit ❰0❱ or ❰""❱ as valid predicates and treat - them as equivalent to ❰False❱. However, the Dhall language does not permit - this - -──────────────────────────────────────────────────────────────────────────────── - -Your ❰if❱ expression begins with the following predicate: - -↳ $txt0 - -... that has type: - -↳ $txt1 - -... but the predicate must instead have type ❰Bool❱ -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty expr1) - -prettyTypeMessage (IfBranchMustBeTerm b expr0 expr1 expr2) = - ErrorMessages {..} - where - short = "❰if❱ branch is not a term" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: Every ❰if❱ expression has a ❰then❱ and ❰else❱ branch, each of which -is an expression: - - - Expression for ❰then❱ branch - ⇩ - ┌────────────────────────────────┐ - │ if True then "Hello, world!" │ - │ else "Goodbye, world!" │ - └────────────────────────────────┘ - ⇧ - Expression for ❰else❱ branch - - -These expressions must be a "term", where a "term" is defined as an expression -that has a type thas has kind ❰Type❱ - -For example, the following expressions are all valid "terms": - - - ┌────────────────────┐ - │ 1 : Integer : Type │ ❰1❱ is a term with a type (❰Integer❱) of kind ❰Type❱ - └────────────────────┘ - ⇧ - term - - - ┌─────────────────────────────────────┐ - │ Natural/odd : Natural → Bool : Type │ ❰Natural/odd❱ is a term with a type - └─────────────────────────────────────┘ (❰Natural → Bool❱) of kind ❰Type❱ - ⇧ - term - - -However, the following expressions are $_NOT valid terms: - - - ┌────────────────────┐ - │ Text : Type : Kind │ ❰Text❱ has kind (❰Type❱) of sort ❰Kind❱ and is - └────────────────────┘ therefore not a term - ⇧ - type - - - ┌───────────────────────────┐ - │ List : Type → Type : Kind │ ❰List❱ has kind (❰Type → Type❱) of sort - └───────────────────────────┘ ❰Kind❱ and is therefore not a term - ⇧ - type-level function - - -This means that you cannot define an ❰if❱ expression that returns a type. For -example, the following ❰if❱ expression is $_NOT valid: - - - ┌─────────────────────────────┐ - │ if True then Text else Bool │ Invalid ❰if❱ expression - └─────────────────────────────┘ - ⇧ ⇧ - type type - - -Your ❰$txt0❱ branch of your ❰if❱ expression is: - -↳ $txt1 - -... which has kind: - -↳ $txt2 - -... of sort: - -↳ $txt3 - -... and is not a term. Therefore your ❰if❱ expression is not valid -|] - where - txt0 = if b then "then" else "else" - txt1 = Text.toStrict (Dhall.Core.pretty expr0) - txt2 = Text.toStrict (Dhall.Core.pretty expr1) - txt3 = Text.toStrict (Dhall.Core.pretty expr2) - -prettyTypeMessage (IfBranchMismatch expr0 expr1 expr2 expr3) = - ErrorMessages {..} - where - short = "❰if❱ branches must have matching types" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: Every ❰if❱ expression has a ❰then❱ and ❰else❱ branch, each of which -is an expression: - - - Expression for ❰then❱ branch - ⇩ - ┌────────────────────────────────┐ - │ if True then "Hello, world!" │ - │ else "Goodbye, world!" │ - └────────────────────────────────┘ - ⇧ - Expression for ❰else❱ branch - - -These two expressions must have the same type. For example, the following ❰if❱ -expressions are all valid: - - - ┌──────────────────────────────────┐ - │ λ(b : Bool) → if b then 0 else 1 │ Both branches have type ❰Integer❱ - └──────────────────────────────────┘ - - - ┌────────────────────────────┐ - │ λ(b : Bool) → │ - │ if b then Natural/even │ Both branches have type ❰Natural → Bool❱ - │ else Natural/odd │ - └────────────────────────────┘ - - -However, the following expression is $_NOT valid: - - - This branch has type ❰Integer❱ - ⇩ - ┌────────────────────────┐ - │ if True then 0 │ - │ else "ABC" │ - └────────────────────────┘ - ⇧ - This branch has type ❰Text❱ - - -The ❰then❱ and ❰else❱ branches must have matching types, even if the predicate is -always ❰True❱ or ❰False❱ - -Your ❰if❱ expression has the following ❰then❱ branch: - -↳ $txt0 - -... which has type: - -↳ $txt2 - -... and the following ❰else❱ branch: - -↳ $txt1 - -... which has a different type: - -↳ $txt3 - -Fix your ❰then❱ and ❰else❱ branches to have matching types -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty expr1) - txt2 = Text.toStrict (Dhall.Core.pretty expr2) - txt3 = Text.toStrict (Dhall.Core.pretty expr3) - -prettyTypeMessage (InvalidListType expr0) = ErrorMessages {..} - where - short = "Invalid type for ❰List❱ elements" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: ❰List❱s can optionally document the type of their elements with a -type annotation, like this: - - - ┌──────────────────────────┐ - │ [1, 2, 3] : List Integer │ A ❰List❱ of three ❰Integer❱s - └──────────────────────────┘ - ⇧ - The type of the ❰List❱'s elements, which are ❰Integer❱s - - - ┌───────────────────┐ - │ [] : List Integer │ An empty ❰List❱ - └───────────────────┘ - ⇧ - You must specify the type when the ❰List❱ is empty - - -The element type must be a type and not something else. For example, the -following element types are $_NOT valid: - - - ┌──────────────┐ - │ ... : List 1 │ - └──────────────┘ - ⇧ - This is an ❰Integer❱ and not a ❰Type❱ - - - ┌─────────────────┐ - │ ... : List Type │ - └─────────────────┘ - ⇧ - This is a ❰Kind❱ and not a ❰Type❱ - - -You declared that the ❰List❱'s elements should have type: - -↳ $txt0 - -... which is not a ❰Type❱ -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - -prettyTypeMessage MissingListType = do - ErrorMessages {..} - where - short = "An empty list requires a type annotation" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: Lists do not require a type annotation if they have at least one -element: - - - ┌───────────┐ - │ [1, 2, 3] │ The compiler can infer that this list has type ❰List Integer❱ - └───────────┘ - - -However, empty lists still require a type annotation: - - - ┌───────────────────┐ - │ [] : List Integer │ This type annotation is mandatory - └───────────────────┘ - - -You cannot supply an empty list without a type annotation -|] - -prettyTypeMessage (MismatchedListElements i expr0 expr1 expr2) = - ErrorMessages {..} - where - short = "List elements should have the same type" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: Every element in a list must have the same type - -For example, this is a valid ❰List❱: - - - ┌───────────┐ - │ [1, 2, 3] │ Every element in this ❰List❱ is an ❰Integer❱ - └───────────┘ - - -.. but this is $_NOT a valid ❰List❱: - - - ┌───────────────┐ - │ [1, "ABC", 3] │ The first and second element have different types - └───────────────┘ - - -Your first ❰List❱ elements has this type: - -↳ $txt0 - -... but the following element at index $txt1: - -↳ $txt2 - -... has this type instead: - -↳ $txt3 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty i ) - txt2 = Text.toStrict (Dhall.Core.pretty expr1) - txt3 = Text.toStrict (Dhall.Core.pretty expr2) - -prettyTypeMessage (InvalidListElement i expr0 expr1 expr2) = - ErrorMessages {..} - where - short = "List element has the wrong type" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: Every element in the list must have a type matching the type -annotation at the end of the list - -For example, this is a valid ❰List❱: - - - ┌──────────────────────────┐ - │ [1, 2, 3] : List Integer │ Every element in this ❰List❱ is an ❰Integer❱ - └──────────────────────────┘ - - -.. but this is $_NOT a valid ❰List❱: - - - ┌──────────────────────────────┐ - │ [1, "ABC", 3] : List Integer │ The second element is not an ❰Integer❱ - └──────────────────────────────┘ - - -Your ❰List❱ elements should have this type: - -↳ $txt0 - -... but the following element at index $txt1: - -↳ $txt2 - -... has this type instead: - -↳ $txt3 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty i ) - txt2 = Text.toStrict (Dhall.Core.pretty expr1) - txt3 = Text.toStrict (Dhall.Core.pretty expr2) - -prettyTypeMessage (InvalidOptionalType expr0) = ErrorMessages {..} - where - short = "Invalid type for ❰Optional❱ element" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: Every optional element ends with a type annotation for the element -that might be present, like this: - - - ┌────────────────────────┐ - │ [1] : Optional Integer │ An optional element that's present - └────────────────────────┘ - ⇧ - The type of the ❰Optional❱ element, which is an ❰Integer❱ - - - ┌────────────────────────┐ - │ [] : Optional Integer │ An optional element that's absent - └────────────────────────┘ - ⇧ - You still specify the type even when the element is absent - - -The element type must be a type and not something else. For example, the -following element types are $_NOT valid: - - - ┌──────────────────┐ - │ ... : Optional 1 │ - └──────────────────┘ - ⇧ - This is an ❰Integer❱ and not a ❰Type❱ - - - ┌─────────────────────┐ - │ ... : Optional Type │ - └─────────────────────┘ - ⇧ - This is a ❰Kind❱ and not a ❰Type❱ - - -Even if the element is absent you still must specify a valid type - -You declared that the ❰Optional❱ element should have type: - -↳ $txt0 - -... which is not a ❰Type❱ - -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - -prettyTypeMessage (InvalidOptionalElement expr0 expr1 expr2) = ErrorMessages {..} - where - short = "❰Optional❱ element has the wrong type" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: An ❰Optional❱ element must have a type matching the type annotation - -For example, this is a valid ❰Optional❱ value: - - - ┌────────────────────────┐ - │ [1] : Optional Integer │ ❰1❱ is an ❰Integer❱, which matches the type - └────────────────────────┘ - - -... but this is $_NOT a valid ❰Optional❱ value: - - - ┌────────────────────────────┐ - │ ["ABC"] : Optional Integer │ ❰"ABC"❱ is not an ❰Integer❱ - └────────────────────────────┘ - - -Your ❰Optional❱ element should have this type: - -↳ $txt0 - -... but the element you provided: - -↳ $txt1 - -... has this type instead: - -↳ $txt2 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty expr1) - txt2 = Text.toStrict (Dhall.Core.pretty expr2) - -prettyTypeMessage (InvalidOptionalLiteral n) = ErrorMessages {..} - where - short = "Multiple ❰Optional❱ elements not allowed" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: The syntax for ❰Optional❱ values resembles the syntax for ❰List❱s: - - - ┌───────────────────────┐ - │ [] : Optional Integer │ An ❰Optional❱ value which is absent - └───────────────────────┘ - - - ┌───────────────────────┐ - │ [] : List Integer │ An empty (0-element) ❰List❱ - └───────────────────────┘ - - - ┌────────────────────────┐ - │ [1] : Optional Integer │ An ❰Optional❱ value which is present - └────────────────────────┘ - - - ┌────────────────────────┐ - │ [1] : List Integer │ A singleton (1-element) ❰List❱ - └────────────────────────┘ - - -However, an ❰Optional❱ value can $_NOT have more than one element, whereas a -❰List❱ can have multiple elements: - - - ┌───────────────────────────┐ - │ [1, 2] : Optional Integer │ Invalid: multiple elements $_NOT allowed - └───────────────────────────┘ - - - ┌───────────────────────────┐ - │ [1, 2] : List Integer │ Valid: multiple elements allowed - └───────────────────────────┘ - - -Some common reasons why you might get this error: - -● You accidentally typed ❰Optional❱ when you meant ❰List❱, like this: - - - ┌────────────────────────────────────────────────────┐ - │ List/length Integer ([1, 2, 3] : Optional Integer) │ - └────────────────────────────────────────────────────┘ - ⇧ - This should be ❰List❱ instead - - -──────────────────────────────────────────────────────────────────────────────── - -Your ❰Optional❱ value had this many elements: - -↳ $txt0 - -... when an ❰Optional❱ value can only have at most one element -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty n) - -prettyTypeMessage (InvalidFieldType k expr0) = ErrorMessages {..} - where - short = "Invalid field type" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: Every record type documents the type of each field, like this: - - ┌──────────────────────────────────────────────┐ - │ { foo : Integer, bar : Integer, baz : Text } │ - └──────────────────────────────────────────────┘ - -However, fields cannot be annotated with expressions other than types - -For example, these record types are $_NOT valid: - - - ┌────────────────────────────┐ - │ { foo : Integer, bar : 1 } │ - └────────────────────────────┘ - ⇧ - ❰1❱ is an ❰Integer❱ and not a ❰Type❱ - - - ┌───────────────────────────────┐ - │ { foo : Integer, bar : Type } │ - └───────────────────────────────┘ - ⇧ - ❰Type❱ is a ❰Kind❱ and not a ❰Type❱ - - -You provided a record type with a key named: - -↳ $txt0 - -... annotated with the following expression: - -↳ $txt1 - -... which is not a type -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty k ) - txt1 = Text.toStrict (Dhall.Core.pretty expr0) - -prettyTypeMessage (InvalidField k expr0) = ErrorMessages {..} - where - short = "Invalid field" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: Every record literal is a set of fields assigned to values, like -this: - - ┌────────────────────────────────────────┐ - │ { foo = 100, bar = True, baz = "ABC" } │ - └────────────────────────────────────────┘ - -However, fields can only be terms and cannot be types or kinds - -For example, these record literals are $_NOT valid: - - - ┌───────────────────────────┐ - │ { foo = 100, bar = Text } │ - └───────────────────────────┘ - ⇧ - ❰Text❱ is a type and not a term - - - ┌───────────────────────────┐ - │ { foo = 100, bar = Type } │ - └───────────────────────────┘ - ⇧ - ❰Type❱ is a kind and not a term - - -You provided a record literal with a key named: - -↳ $txt0 - -... whose value is: - -↳ $txt1 - -... which is not a term -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty k ) - txt1 = Text.toStrict (Dhall.Core.pretty expr0) - -prettyTypeMessage (InvalidAlternativeType k expr0) = ErrorMessages {..} - where - short = "Invalid alternative" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: Every union literal begins by selecting one alternative and -specifying the value for that alternative, like this: - - - Select the ❰Left❱ alternative, whose value is ❰True❱ - ⇩ - ┌──────────────────────────────────┐ - │ < Left = True, Right : Natural > │ A union literal with two alternatives - └──────────────────────────────────┘ - - -However, this value must be a term and not a type. For example, the following -values are $_NOT valid: - - - ┌──────────────────────────────────┐ - │ < Left = Text, Right : Natural > │ Invalid union literal - └──────────────────────────────────┘ - ⇧ - This is a type and not a term - - - ┌───────────────────────────────┐ - │ < Left = Type, Right : Type > │ Invalid union type - └───────────────────────────────┘ - ⇧ - This is a kind and not a term - - -Some common reasons why you might get this error: - -● You accidentally typed ❰=❱ instead of ❰:❱ for a union literal with one - alternative: - - - ┌────────────────────┐ - │ < Example = Text > │ - └────────────────────┘ - ⇧ - This could be ❰:❱ instead - - -──────────────────────────────────────────────────────────────────────────────── - -You provided a union literal with an alternative named: - -↳ $txt0 - -... whose value is: - -↳ $txt1 - -... which is not a term -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty k ) - txt1 = Text.toStrict (Dhall.Core.pretty expr0) - -prettyTypeMessage (InvalidAlternative k expr0) = ErrorMessages {..} - where - short = "Invalid alternative" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: Every union type specifies the type of each alternative, like this: - - - The type of the first alternative is ❰Bool❱ - ⇩ - ┌──────────────────────────────────┐ - │ < Left : Bool, Right : Natural > │ A union type with two alternatives - └──────────────────────────────────┘ - ⇧ - The type of the second alternative is ❰Natural❱ - - -However, these alternatives can only be annotated with types. For example, the -following union types are $_NOT valid: - - - ┌────────────────────────────┐ - │ < Left : Bool, Right : 1 > │ Invalid union type - └────────────────────────────┘ - ⇧ - This is a term and not a type - - - ┌───────────────────────────────┐ - │ < Left : Bool, Right : Type > │ Invalid union type - └───────────────────────────────┘ - ⇧ - This is a kind and not a type - - -Some common reasons why you might get this error: - -● You accidentally typed ❰:❱ instead of ❰=❱ for a union literal with one - alternative: - - ┌─────────────────┐ - │ < Example : 1 > │ - └─────────────────┘ - ⇧ - This could be ❰=❱ instead - - -──────────────────────────────────────────────────────────────────────────────── - -You provided a union type with an alternative named: - -↳ $txt0 - -... annotated with the following expression which is not a type: - -↳ $txt1 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty k ) - txt1 = Text.toStrict (Dhall.Core.pretty expr0) - -prettyTypeMessage (DuplicateAlternative k) = ErrorMessages {..} - where - short = "Duplicate union alternative" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: Unions may not have two alternatives that share the same name - -For example, the following expressions are $_NOT valid: - - - ┌─────────────────────────────┐ - │ < foo = True | foo : Text > │ Invalid: ❰foo❱ appears twice - └─────────────────────────────┘ - - - ┌───────────────────────────────────────┐ - │ < foo = 1 | bar : Bool | bar : Text > │ Invalid: ❰bar❱ appears twice - └───────────────────────────────────────┘ - - -You have more than one alternative named: - -↳ $txt0 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty k) - -prettyTypeMessage (MustCombineARecord c expr0 expr1) = ErrorMessages {..} - where - short = "You can only combine records" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: You can combine records using the ❰$op❱ operator, like this: - - - ┌───────────────────────────────────────────┐ - │ { foo = 1, bar = "ABC" } $op { baz = True } │ - └───────────────────────────────────────────┘ - - - ┌─────────────────────────────────────────────┐ - │ λ(r : { foo : Bool }) → r $op { bar = "ABC" } │ - └─────────────────────────────────────────────┘ - - -... but you cannot combine values that are not records. - -For example, the following expressions are $_NOT valid: - - - ┌──────────────────────────────┐ - │ { foo = 1, bar = "ABC" } $op 1 │ - └──────────────────────────────┘ - ⇧ - Invalid: Not a record - - - ┌───────────────────────────────────────────┐ - │ { foo = 1, bar = "ABC" } $op { baz : Bool } │ - └───────────────────────────────────────────┘ - ⇧ - Invalid: This is a record type and not a record - - - ┌───────────────────────────────────────────┐ - │ { foo = 1, bar = "ABC" } $op < baz = True > │ - └───────────────────────────────────────────┘ - ⇧ - Invalid: This is a union and not a record - - -You tried to combine the following value: - -↳ $txt0 - -... which is not a record, but is actually a: - -↳ $txt1 -|] - where - op = Data.Text.singleton c - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty expr1) - -prettyTypeMessage (FieldCollision k) = ErrorMessages {..} - where - short = "Field collision" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: You can combine records if they don't share any fields in common, -like this: - - - ┌───────────────────────────────────────────┐ - │ { foo = 1, bar = "ABC" } ∧ { baz = True } │ - └───────────────────────────────────────────┘ - - - ┌────────────────────────────────────────┐ - │ λ(r : { baz : Bool}) → { foo = 1 } ∧ r │ - └────────────────────────────────────────┘ - - -... but you cannot merge two records that share the same field - -For example, the following expression is $_NOT valid: - - - ┌───────────────────────────────────────────┐ - │ { foo = 1, bar = "ABC" } ∧ { foo = True } │ Invalid: Colliding ❰foo❱ fields - └───────────────────────────────────────────┘ - - -Some common reasons why you might get this error: - -● You tried to use ❰∧❱ to update a field's value, like this: - - - ┌────────────────────────────────────────┐ - │ { foo = 1, bar = "ABC" } ∧ { foo = 2 } │ - └────────────────────────────────────────┘ - ⇧ - Invalid attempt to update ❰foo❱'s value to ❰2❱ - - Field updates are intentionally not allowed as the Dhall language discourages - patch-oriented programming - -──────────────────────────────────────────────────────────────────────────────── - -You combined two records that share the following field: - -↳ $txt0 - -... which is not allowed -|] - where - txt0 = Text.toStrict k - -prettyTypeMessage (MustMergeARecord expr0 expr1) = ErrorMessages {..} - where - short = "❰merge❱ expects a record of handlers" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: You can ❰merge❱ the alternatives of a union using a record with one -handler per alternative, like this: - - - ┌─────────────────────────────────────────────────────────────────────┐ - │ let union = < Left = +2 | Right : Bool > │ - │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ - │ in merge handlers union : Bool │ - └─────────────────────────────────────────────────────────────────────┘ - - -... but the first argument to ❰merge❱ must be a record and not some other type. - -For example, the following expression is $_NOT valid: - - - ┌─────────────────────────────────────────┐ - │ let handler = λ(x : Bool) → x │ - │ in merge handler < Foo = True > : True │ - └─────────────────────────────────────────┘ - ⇧ - Invalid: ❰handler❱ isn't a record - - -Some common reasons why you might get this error: - -● You accidentally provide an empty record type instead of an empty record when - you ❰merge❱ an empty union: - - - ┌──────────────────────────────────────────┐ - │ λ(x : <>) → λ(a : Type) → merge {} x : a │ - └──────────────────────────────────────────┘ - ⇧ - This should be ❰{=}❱ instead - - -──────────────────────────────────────────────────────────────────────────────── - -You provided the following handler: - -↳ $txt0 - -... which is not a record, but is actually a value of type: - -↳ $txt1 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty expr1) - -prettyTypeMessage (MustMergeUnion expr0 expr1) = ErrorMessages {..} - where - short = "❰merge❱ expects a union" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: You can ❰merge❱ the alternatives of a union using a record with one -handler per alternative, like this: - - - ┌─────────────────────────────────────────────────────────────────────┐ - │ let union = < Left = +2 | Right : Bool > │ - │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ - │ in merge handlers union : Bool │ - └─────────────────────────────────────────────────────────────────────┘ - - -... but the second argument to ❰merge❱ must be a union and not some other type. - -For example, the following expression is $_NOT valid: - - - ┌──────────────────────────────────────────┐ - │ let handlers = { Foo = λ(x : Bool) → x } │ - │ in merge handlers True : True │ - └──────────────────────────────────────────┘ - ⇧ - Invalid: ❰True❱ isn't a union - - -You tried to ❰merge❱ this expression: - -↳ $txt0 - -... which is not a union, but is actually a value of type: - -↳ $txt1 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty expr1) - -prettyTypeMessage (UnusedHandler ks) = ErrorMessages {..} - where - short = "Unused handler" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: You can ❰merge❱ the alternatives of a union using a record with one -handler per alternative, like this: - - - ┌─────────────────────────────────────────────────────────────────────┐ - │ let union = < Left = +2 | Right : Bool > │ - │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ - │ in merge handlers union : Bool │ - └─────────────────────────────────────────────────────────────────────┘ - - -... but you must provide exactly one handler per alternative in the union. You -cannot supply extra handlers - -For example, the following expression is $_NOT valid: - - - ┌───────────────────────────────────────┐ - │ let union = < Left = +2 > │ The ❰Right❱ alternative is missing - │ in let handlers = │ - │ { Left = Natural/even │ - │ , Right = λ(x : Bool) → x │ Invalid: ❰Right❱ handler isn't used - │ } │ - │ in merge handlers union : Bool │ - └───────────────────────────────────────┘ - - -You provided the following handlers: - -↳ $txt0 - -... which had no matching alternatives in the union you tried to ❰merge❱ -|] - where - txt0 = Text.toStrict (Text.intercalate ", " (Data.Set.toList ks)) - -prettyTypeMessage (MissingHandler ks) = ErrorMessages {..} - where - short = "Missing handler" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: You can ❰merge❱ the alternatives of a union using a record with one -handler per alternative, like this: - - - ┌─────────────────────────────────────────────────────────────────────┐ - │ let union = < Left = +2 | Right : Bool > │ - │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ - │ in merge handlers union : Bool │ - └─────────────────────────────────────────────────────────────────────┘ - - -... but you must provide exactly one handler per alternative in the union. You -cannot omit any handlers - -For example, the following expression is $_NOT valid: - - - Invalid: Missing ❰Right❱ handler - ⇩ - ┌─────────────────────────────────────────────────┐ - │ let handlers = { Left = Natural/even } │ - │ in let union = < Left = +2 | Right : Bool > │ - │ in merge handlers union : Bool │ - └─────────────────────────────────────────────────┘ - - -Note that you need to provide handlers for other alternatives even if those -alternatives are never used - -You need to supply the following handlers: - -↳ $txt0 -|] - where - txt0 = Text.toStrict (Text.intercalate ", " (Data.Set.toList ks)) - -prettyTypeMessage MissingMergeType = - ErrorMessages {..} - where - short = "An empty ❰merge❱ requires a type annotation" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: A ❰merge❱ does not require a type annotation if the union has at -least one alternative, like this - - - ┌─────────────────────────────────────────────────────────────────────┐ - │ let union = < Left = +2 | Right : Bool > │ - │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ - │ in merge handlers union │ - └─────────────────────────────────────────────────────────────────────┘ - - -However, you must provide a type annotation when merging an empty union: - - - ┌────────────────────────────────┐ - │ λ(a : <>) → merge {=} a : Bool │ - └────────────────────────────────┘ - ⇧ - This can be any type - - -You can provide any type at all as the annotation, since merging an empty -union can produce any type of output -|] - -prettyTypeMessage (HandlerInputTypeMismatch expr0 expr1 expr2) = - ErrorMessages {..} - where - short = "Wrong handler input type" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: You can ❰merge❱ the alternatives of a union using a record with one -handler per alternative, like this: - - - ┌─────────────────────────────────────────────────────────────────────┐ - │ let union = < Left = +2 | Right : Bool > │ - │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ - │ in merge handlers union : Bool │ - └─────────────────────────────────────────────────────────────────────┘ - - -... as long as the input type of each handler function matches the type of the -corresponding alternative: - - - ┌───────────────────────────────────────────────────────────┐ - │ union : < Left : Natural | Right : Bool > │ - └───────────────────────────────────────────────────────────┘ - ⇧ ⇧ - These must match These must match - ⇩ ⇩ - ┌───────────────────────────────────────────────────────────┐ - │ handlers : { Left : Natural → Bool, Right : Bool → Bool } │ - └───────────────────────────────────────────────────────────┘ - - -For example, the following expression is $_NOT valid: - - - Invalid: Doesn't match the type of the ❰Right❱ alternative - ⇩ - ┌──────────────────────────────────────────────────────────────────────┐ - │ let handlers = { Left = Natural/even | Right = λ(x : Text) → x } │ - │ in let union = < Left = +2 | Right : Bool > │ - │ in merge handlers union : Bool │ - └──────────────────────────────────────────────────────────────────────┘ - - -Your handler for the following alternative: - -↳ $txt0 - -... needs to accept an input value of type: - -↳ $txt1 - -... but actually accepts an input value of a different type: - -↳ $txt2 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty expr1) - txt2 = Text.toStrict (Dhall.Core.pretty expr2) - -prettyTypeMessage (InvalidHandlerOutputType expr0 expr1 expr2) = - ErrorMessages {..} - where - short = "Wrong handler output type" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: You can ❰merge❱ the alternatives of a union using a record with one -handler per alternative, like this: - - - ┌─────────────────────────────────────────────────────────────────────┐ - │ let union = < Left = +2 | Right : Bool > │ - │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ - │ in merge handlers union : Bool │ - └─────────────────────────────────────────────────────────────────────┘ - - -... as long as the output type of each handler function matches the declared type -of the result: - - - ┌───────────────────────────────────────────────────────────┐ - │ handlers : { Left : Natural → Bool, Right : Bool → Bool } │ - └───────────────────────────────────────────────────────────┘ - ⇧ ⇧ - These output types ... - - ... must match the declared type of the ❰merge❱ - ⇩ - ┌─────────────────────────────┐ - │ merge handlers union : Bool │ - └─────────────────────────────┘ - - -For example, the following expression is $_NOT valid: - - - ┌──────────────────────────────────────────────────────────────────────┐ - │ let union = < Left = +2 | Right : Bool > │ - │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ - │ in merge handlers union : Text │ - └──────────────────────────────────────────────────────────────────────┘ - ⇧ - Invalid: Doesn't match output of either handler - - -Your handler for the following alternative: - -↳ $txt0 - -... needs to return an output value of type: - -↳ $txt1 - -... but actually returns an output value of a different type: - -↳ $txt2 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty expr1) - txt2 = Text.toStrict (Dhall.Core.pretty expr2) - -prettyTypeMessage (HandlerOutputTypeMismatch key0 expr0 key1 expr1) = - ErrorMessages {..} - where - short = "Handlers should have the same output type" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: You can ❰merge❱ the alternatives of a union using a record with one -handler per alternative, like this: - - - ┌─────────────────────────────────────────────────────────────────────┐ - │ let union = < Left = +2 | Right : Bool > │ - │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ - │ in merge handlers union │ - └─────────────────────────────────────────────────────────────────────┘ - - -... as long as the output type of each handler function is the same: - - - ┌───────────────────────────────────────────────────────────┐ - │ handlers : { Left : Natural → Bool, Right : Bool → Bool } │ - └───────────────────────────────────────────────────────────┘ - ⇧ ⇧ - These output types both match - - -For example, the following expression is $_NOT valid: - - - ┌─────────────────────────────────────────────────┐ - │ let union = < Left = +2 | Right : Bool > │ - │ in let handlers = │ - │ { Left = λ(x : Natural) → x │ This outputs ❰Natural❱ - │ , Right = λ(x : Bool ) → x │ This outputs ❰Bool❱ - │ } │ - │ in merge handlers union │ - └─────────────────────────────────────────────────┘ - ⇧ - Invalid: The handlers in this record don't have matching outputs - - -The handler for the ❰$txt0❱ alternative has this output type: - -↳ $txt1 - -... but the handler for the ❰$txt2❱ alternative has this output type instead: - -↳ $txt3 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty key0 ) - txt1 = Text.toStrict (Dhall.Core.pretty expr0) - txt2 = Text.toStrict (Dhall.Core.pretty key1 ) - txt3 = Text.toStrict (Dhall.Core.pretty expr1) -prettyTypeMessage (HandlerNotAFunction k expr0) = ErrorMessages {..} - where - short = "Handler is not a function" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: You can ❰merge❱ the alternatives of a union using a record with one -handler per alternative, like this: - - - ┌─────────────────────────────────────────────────────────────────────┐ - │ let union = < Left = +2 | Right : Bool > │ - │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ - │ in merge handlers union : Bool │ - └─────────────────────────────────────────────────────────────────────┘ - - -... as long as each handler is a function - -For example, the following expression is $_NOT valid: - - - ┌─────────────────────────────────────────┐ - │ merge { Foo = True } < Foo = 1 > : Bool │ - └─────────────────────────────────────────┘ - ⇧ - Invalid: Not a function - - -Your handler for this alternative: - -↳ $txt0 - -... has the following type: - -↳ $txt1 - -... which is not the type of a function -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty k) - txt1 = Text.toStrict (Dhall.Core.pretty expr0) - -prettyTypeMessage (NotARecord k expr0 expr1) = ErrorMessages {..} - where - short = "Not a record" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: You can only access fields on records, like this: - - - ┌─────────────────────────────────┐ - │ { foo = True, bar = "ABC" }.foo │ This is valid ... - └─────────────────────────────────┘ - - - ┌───────────────────────────────────────────┐ - │ λ(r : { foo : Bool, bar : Text }) → r.foo │ ... and so is this - └───────────────────────────────────────────┘ - - -... but you cannot access fields on non-record expressions - -For example, the following expression is $_NOT valid: - - - ┌───────┐ - │ 1.foo │ - └───────┘ - ⇧ - Invalid: Not a record - - -Some common reasons why you might get this error: - -● You accidentally try to access a field of a union instead of a record, like - this: - - - ┌─────────────────┐ - │ < foo : a >.foo │ - └─────────────────┘ - ⇧ - This is a union, not a record - - -──────────────────────────────────────────────────────────────────────────────── - -You tried to access a field named: - -↳ $txt0 - -... on the following expression which is not a record: - -↳ $txt1 - -... but is actually an expression of type: - -↳ $txt2 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty k ) - txt1 = Text.toStrict (Dhall.Core.pretty expr0) - txt2 = Text.toStrict (Dhall.Core.pretty expr1) - -prettyTypeMessage (MissingField k expr0) = ErrorMessages {..} - where - short = "Missing record field" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: You can only access fields on records, like this: - - - ┌─────────────────────────────────┐ - │ { foo = True, bar = "ABC" }.foo │ This is valid ... - └─────────────────────────────────┘ - - - ┌───────────────────────────────────────────┐ - │ λ(r : { foo : Bool, bar : Text }) → r.foo │ ... and so is this - └───────────────────────────────────────────┘ - - -... but you can only access fields if they are present - -For example, the following expression is $_NOT valid: - - ┌─────────────────────────────────┐ - │ { foo = True, bar = "ABC" }.qux │ - └─────────────────────────────────┘ - ⇧ - Invalid: the record has no ❰qux❱ field - -You tried to access a field named: - -↳ $txt0 - -... but the field is missing because the record only defines the following fields: - -↳ $txt1 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty k ) - txt1 = Text.toStrict (Dhall.Core.pretty expr0) - -prettyTypeMessage (CantAnd expr0 expr1) = - buildBooleanOperator "&&" expr0 expr1 - -prettyTypeMessage (CantOr expr0 expr1) = - buildBooleanOperator "||" expr0 expr1 - -prettyTypeMessage (CantEQ expr0 expr1) = - buildBooleanOperator "==" expr0 expr1 - -prettyTypeMessage (CantNE expr0 expr1) = - buildBooleanOperator "/=" expr0 expr1 - -prettyTypeMessage (CantTextAppend expr0 expr1) = ErrorMessages {..} - where - short = "❰++❱ only works on ❰Text❱" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: The ❰++❱ operator expects two arguments that have type ❰Text❱ - -For example, this is a valid use of ❰++❱: - - - ┌────────────────┐ - │ "ABC" ++ "DEF" │ - └────────────────┘ - - -Some common reasons why you might get this error: - -● You might have thought that ❰++❱ was the operator to combine two lists: - - - ┌────────────────────────┐ - │ [1, 2, 3] ++ [4, 5, 6] │ Not valid - └────────────────────────┘ - - - The Dhall programming language does not provide a built-in operator for - combining two lists - -──────────────────────────────────────────────────────────────────────────────── - -You provided this argument: - -↳ $txt0 - -... which does not have type ❰Text❱ but instead has type: - -↳ $txt1 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty expr1) - -prettyTypeMessage (CantAdd expr0 expr1) = - buildNaturalOperator "+" expr0 expr1 - -prettyTypeMessage (CantMultiply expr0 expr1) = - buildNaturalOperator "*" expr0 expr1 - -prettyTypeMessage (NoDependentTypes expr0 expr1) = ErrorMessages {..} - where - short = "No dependent types" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: The Dhall programming language does not allow functions from terms -to types. These function types are also known as "dependent function types" -because you have a type whose value "depends" on the value of a term. - -For example, this is $_NOT a legal function type: - - - ┌─────────────┐ - │ Bool → Type │ - └─────────────┘ - - -Similarly, this is $_NOT legal code: - - - ┌────────────────────────────────────────────────────┐ - │ λ(Vector : Natural → Type → Type) → Vector +0 Text │ - └────────────────────────────────────────────────────┘ - ⇧ - Invalid dependent type - - -Your function type is invalid because the input has type: - -↳ $txt0 - -... and the output has kind: - -↳ $txt1 - -... which makes this a forbidden dependent function type -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty expr1) - -prettyTypeMessage (NoDependentLet expr0 expr1) = ErrorMessages {..} - where - short = "No dependent ❰let❱" - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: The Dhall programming language does not allow ❰let❱ expressions -from terms to types. These ❰let❱ expressions are also known as "dependent ❰let❱ -expressions" because you have a type whose value depends on the value of a term. - -The Dhall language forbids these dependent ❰let❱ expressions in order to -guarantee that ❰let❱ expressions of the form: - - - ┌────────────────────┐ - │ let x : t = r in e │ - └────────────────────┘ - - -... are always equivalent to: - - - ┌──────────────────┐ - │ (λ(x : t) → e) r │ - └──────────────────┘ - - -This means that both expressions should normalize to the same result and if one -of the two fails to type check then the other should fail to type check, too. - -For this reason, the following is $_NOT legal code: - - - ┌───────────────────┐ - │ let x = 2 in Text │ - └───────────────────┘ - - -... because the above ❰let❱ expression is equivalent to: - - - ┌─────────────────────────────┐ - │ let x : Integer = 2 in Text │ - └─────────────────────────────┘ - - -... which in turn must be equivalent to: - - - ┌───────────────────────────┐ - │ (λ(x : Integer) → Text) 2 │ - └───────────────────────────┘ - - -... which in turn fails to type check because this sub-expression: - - - ┌───────────────────────┐ - │ λ(x : Integer) → Text │ - └───────────────────────┘ - - -... has type: - - - ┌───────────────────────┐ - │ ∀(x : Integer) → Text │ - └───────────────────────┘ - - -... which is a forbidden dependent function type (i.e. a function from a term to -a type). Therefore the equivalent ❰let❱ expression is also forbidden. - -Your ❰let❱ expression is invalid because the input has type: - -↳ $txt0 - -... and the output has kind: - -↳ $txt1 - -... which makes this a forbidden dependent ❰let❱ expression -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty expr1) - -buildBooleanOperator :: Text -> Expr s X -> Expr s X -> ErrorMessages -buildBooleanOperator operator expr0 expr1 = ErrorMessages {..} - where - short = - Builder.fromText - (Data.Text.strip - [NeatInterpolation.text|❰$txt2❱ only works on ❰Bool❱s|] ) - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: The ❰$txt2❱ operator expects two arguments that have type ❰Bool❱ - -For example, this is a valid use of ❰$txt2❱: - - - ┌───────────────┐ - │ True $txt2 False │ - └───────────────┘ - - -You provided this argument: - -↳ $txt0 - -... which does not have type ❰Bool❱ but instead has type: - -↳ $txt1 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty expr1) - - txt2 = Text.toStrict operator - -buildNaturalOperator :: Text -> Expr s X -> Expr s X -> ErrorMessages -buildNaturalOperator operator expr0 expr1 = ErrorMessages {..} - where - short = - Builder.fromText - (Data.Text.strip - [NeatInterpolation.text|❰$txt2❱ only works on ❰Natural❱s|] ) - - long = - Builder.fromText [NeatInterpolation.text| -Explanation: The ❰$txt2❱ operator expects two arguments that have type ❰Natural❱ - -For example, this is a valid use of ❰$txt2❱: - - - ┌─────────┐ - │ +3 $txt2 +5 │ - └─────────┘ - - -Some common reasons why you might get this error: - -● You might have tried to use an ❰Integer❱, which is $_NOT allowed: - - - ┌─────────────────────────────────────────┐ - │ λ(x : Integer) → λ(y : Integer) → x $txt2 y │ Not valid - └─────────────────────────────────────────┘ - - - You can only use ❰Natural❱ numbers - - -● You might have mistakenly used an ❰Integer❱ literal, which is $_NOT allowed: - - - ┌───────┐ - │ 2 $txt2 2 │ Not valid - └───────┘ - - - You need to prefix each literal with a ❰+❱ to transform them into ❰Natural❱ - literals, like this: - - - ┌─────────┐ - │ +2 $txt2 +2 │ Valid - └─────────┘ - - -──────────────────────────────────────────────────────────────────────────────── - -You provided this argument: - -↳ $txt0 - -... which does not have type ❰Natural❱ but instead has type: - -↳ $txt1 -|] - where - txt0 = Text.toStrict (Dhall.Core.pretty expr0) - txt1 = Text.toStrict (Dhall.Core.pretty expr1) - - txt2 = Text.toStrict operator +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wall #-} + +-- | This module contains the logic for type checking Dhall code + +module Dhall.TypeCheck ( + -- * Type-checking + typeWith + , typeOf + + -- * Types + , X(..) + , TypeError(..) + , DetailedTypeError(..) + , TypeMessage(..) + ) where + +import Control.Exception (Exception) +import Data.Foldable (forM_, toList) +import Data.Monoid ((<>)) +import Data.Set (Set) +import Data.Text.Buildable (Buildable(..)) +import Data.Text.Lazy (Text) +import Data.Text.Lazy.Builder (Builder) +import Data.Traversable (forM) +import Data.Typeable (Typeable) +import Dhall.Core (Const(..), Expr(..), Var(..)) +import Dhall.Context (Context) + +import qualified Control.Monad.Trans.State.Strict as State +import qualified Data.Map +import qualified Data.Set +import qualified Data.Text.Lazy as Text +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Vector +import qualified Dhall.Context +import qualified Dhall.Core + +axiom :: Const -> Either (TypeError s) Const +axiom Type = return Kind +axiom Kind = Left (TypeError Dhall.Context.empty (Const Kind) Untyped) + +rule :: Const -> Const -> Either () Const +rule Type Kind = Left () +rule Type Type = return Type +rule Kind Kind = return Kind +rule Kind Type = return Type + +match :: Var -> Var -> [(Text, Text)] -> Bool +match (V xL nL) (V xR nR) [] = + xL == xR && nL == nR +match (V xL 0 ) (V xR 0 ) ((xL', xR'):_ ) + | xL == xL' && xR == xR' = True +match (V xL nL) (V xR nR) ((xL', xR'):xs) = + match (V xL nL') (V xR nR') xs + where + nL' = if xL == xL' then nL - 1 else nL + nR' = if xR == xR' then nR - 1 else nR + +propEqual :: Expr s X -> Expr t X -> Bool +propEqual eL0 eR0 = + State.evalState + (go (Dhall.Core.normalize eL0) (Dhall.Core.normalize eR0)) + [] + where + go (Const Type) (Const Type) = return True + go (Const Kind) (Const Kind) = return True + go (Var vL) (Var vR) = do + ctx <- State.get + return (match vL vR ctx) + go (Pi xL tL bL) (Pi xR tR bR) = do + ctx <- State.get + eq1 <- go tL tR + if eq1 + then do + State.put ((xL, xR):ctx) + eq2 <- go bL bR + State.put ctx + return eq2 + else return False + go (App fL aL) (App fR aR) = do + b1 <- go fL fR + if b1 then go aL aR else return False + go Bool Bool = return True + go Natural Natural = return True + go Integer Integer = return True + go Double Double = return True + go Text Text = return True + go List List = return True + go Optional Optional = return True + go (Record ktsL0) (Record ktsR0) = do + let loop ((kL, tL):ktsL) ((kR, tR):ktsR) + | kL == kR = do + b <- go tL tR + if b + then loop ktsL ktsR + else return False + loop [] [] = return True + loop _ _ = return False + loop (Data.Map.toList ktsL0) (Data.Map.toList ktsR0) + go (Union ktsL0) (Union ktsR0) = do + let loop ((kL, tL):ktsL) ((kR, tR):ktsR) + | kL == kR = do + b <- go tL tR + if b + then loop ktsL ktsR + else return False + loop [] [] = return True + loop _ _ = return False + loop (Data.Map.toList ktsL0) (Data.Map.toList ktsR0) + go _ _ = return False + +{-| Type-check an expression and return the expression's type if type-checking + succeeds or an error if type-checking fails + + `typeWith` does not necessarily normalize the type since full normalization + is not necessary for just type-checking. If you actually care about the + returned type then you may want to `Dhall.Core.normalize` it afterwards. +-} +typeWith :: Context (Expr s X) -> Expr s X -> Either (TypeError s) (Expr s X) +typeWith _ (Const c ) = do + fmap Const (axiom c) +typeWith ctx e@(Var (V x n) ) = do + case Dhall.Context.lookup x n ctx of + Nothing -> Left (TypeError ctx e UnboundVariable) + Just a -> return a +typeWith ctx (Lam x _A b ) = do + let ctx' = fmap (Dhall.Core.shift 1 (V x 0)) (Dhall.Context.insert x _A ctx) + _B <- typeWith ctx' b + let p = Pi x _A _B + _t <- typeWith ctx p + return p +typeWith ctx e@(Pi x _A _B ) = do + tA <- fmap Dhall.Core.normalize (typeWith ctx _A) + kA <- case tA of + Const k -> return k + _ -> Left (TypeError ctx e (InvalidInputType _A)) + + let ctx' = fmap (Dhall.Core.shift 1 (V x 0)) (Dhall.Context.insert x _A ctx) + tB <- fmap Dhall.Core.normalize (typeWith ctx' _B) + kB <- case tB of + Const k -> return k + _ -> Left (TypeError ctx' e (InvalidOutputType _B)) + + case rule kA kB of + Left () -> Left (TypeError ctx e (NoDependentTypes _A _B)) + Right k -> Right (Const k) +typeWith ctx e@(App f a ) = do + tf <- fmap Dhall.Core.normalize (typeWith ctx f) + (x, _A, _B) <- case tf of + Pi x _A _B -> return (x, _A, _B) + _ -> Left (TypeError ctx e (NotAFunction f tf)) + _A' <- typeWith ctx a + if propEqual _A _A' + then do + let a' = Dhall.Core.shift 1 (V x 0) a + let _B' = Dhall.Core.subst (V x 0) a' _B + let _B'' = Dhall.Core.shift (-1) (V x 0) _B' + return _B'' + else do + let nf_A = Dhall.Core.normalize _A + let nf_A' = Dhall.Core.normalize _A' + Left (TypeError ctx e (TypeMismatch f nf_A a nf_A')) +typeWith ctx e@(Let f mt r b ) = do + tR <- typeWith ctx r + ttR <- fmap Dhall.Core.normalize (typeWith ctx tR) + kR <- case ttR of + Const k -> return k + -- Don't bother to provide a `let`-specific version of this error + -- message because this should never happen anyway + _ -> Left (TypeError ctx e (InvalidInputType tR)) + + let ctx' = Dhall.Context.insert f tR ctx + tB <- typeWith ctx' b + ttB <- fmap Dhall.Core.normalize (typeWith ctx tB) + kB <- case ttB of + Const k -> return k + -- Don't bother to provide a `let`-specific version of this error + -- message because this should never happen anyway + _ -> Left (TypeError ctx e (InvalidOutputType tB)) + + case rule kR kB of + Left () -> Left (TypeError ctx e (NoDependentLet tR tB)) + Right _ -> return () + + case mt of + Nothing -> do + return () + Just t -> do + let nf_t = Dhall.Core.normalize t + let nf_tR = Dhall.Core.normalize tR + if propEqual nf_tR nf_t + then return () + else Left (TypeError ctx e (AnnotMismatch r nf_t nf_tR)) + + return tB +typeWith ctx e@(Annot x t ) = do + -- This is mainly just to check that `t` is not `Kind` + _ <- typeWith ctx t + + t' <- typeWith ctx x + if propEqual t t' + then do + return t + else do + let nf_t = Dhall.Core.normalize t + let nf_t' = Dhall.Core.normalize t' + Left (TypeError ctx e (AnnotMismatch x nf_t nf_t')) +typeWith _ Bool = do + return (Const Type) +typeWith _ (BoolLit _ ) = do + return Bool +typeWith ctx e@(BoolAnd l r ) = do + tl <- fmap Dhall.Core.normalize (typeWith ctx l) + case tl of + Bool -> return () + _ -> Left (TypeError ctx e (CantAnd l tl)) + + tr <- fmap Dhall.Core.normalize (typeWith ctx r) + case tr of + Bool -> return () + _ -> Left (TypeError ctx e (CantAnd r tr)) + + return Bool +typeWith ctx e@(BoolOr l r ) = do + tl <- fmap Dhall.Core.normalize (typeWith ctx l) + case tl of + Bool -> return () + _ -> Left (TypeError ctx e (CantOr l tl)) + + tr <- fmap Dhall.Core.normalize (typeWith ctx r) + case tr of + Bool -> return () + _ -> Left (TypeError ctx e (CantOr r tr)) + + return Bool +typeWith ctx e@(BoolEQ l r ) = do + tl <- fmap Dhall.Core.normalize (typeWith ctx l) + case tl of + Bool -> return () + _ -> Left (TypeError ctx e (CantEQ l tl)) + + tr <- fmap Dhall.Core.normalize (typeWith ctx r) + case tr of + Bool -> return () + _ -> Left (TypeError ctx e (CantEQ r tr)) + + return Bool +typeWith ctx e@(BoolNE l r ) = do + tl <- fmap Dhall.Core.normalize (typeWith ctx l) + case tl of + Bool -> return () + _ -> Left (TypeError ctx e (CantNE l tl)) + + tr <- fmap Dhall.Core.normalize (typeWith ctx r) + case tr of + Bool -> return () + _ -> Left (TypeError ctx e (CantNE r tr)) + + return Bool +typeWith ctx e@(BoolIf x y z ) = do + tx <- fmap Dhall.Core.normalize (typeWith ctx x) + case tx of + Bool -> return () + _ -> Left (TypeError ctx e (InvalidPredicate x tx)) + ty <- fmap Dhall.Core.normalize (typeWith ctx y ) + tty <- fmap Dhall.Core.normalize (typeWith ctx ty) + case tty of + Const Type -> return () + _ -> Left (TypeError ctx e (IfBranchMustBeTerm True y ty tty)) + + tz <- fmap Dhall.Core.normalize (typeWith ctx z) + ttz <- fmap Dhall.Core.normalize (typeWith ctx tz) + case ttz of + Const Type -> return () + _ -> Left (TypeError ctx e (IfBranchMustBeTerm False z tz ttz)) + + if propEqual ty tz + then return () + else Left (TypeError ctx e (IfBranchMismatch y z ty tz)) + return ty +typeWith _ Natural = do + return (Const Type) +typeWith _ (NaturalLit _ ) = do + return Natural +typeWith _ NaturalFold = do + return + (Pi "_" Natural + (Pi "natural" (Const Type) + (Pi "succ" (Pi "_" "natural" "natural") + (Pi "zero" "natural" "natural") ) ) ) +typeWith _ NaturalBuild = do + return + (Pi "_" + (Pi "natural" (Const Type) + (Pi "succ" (Pi "_" "natural" "natural") + (Pi "zero" "natural" "natural") ) ) + Natural ) +typeWith _ NaturalIsZero = do + return (Pi "_" Natural Bool) +typeWith _ NaturalEven = do + return (Pi "_" Natural Bool) +typeWith _ NaturalOdd = do + return (Pi "_" Natural Bool) +typeWith _ NaturalToInteger = do + return (Pi "_" Natural Integer) +typeWith _ NaturalShow = do + return (Pi "_" Natural Text) +typeWith ctx e@(NaturalPlus l r) = do + tl <- fmap Dhall.Core.normalize (typeWith ctx l) + case tl of + Natural -> return () + _ -> Left (TypeError ctx e (CantAdd l tl)) + + tr <- fmap Dhall.Core.normalize (typeWith ctx r) + case tr of + Natural -> return () + _ -> Left (TypeError ctx e (CantAdd r tr)) + return Natural +typeWith ctx e@(NaturalTimes l r) = do + tl <- fmap Dhall.Core.normalize (typeWith ctx l) + case tl of + Natural -> return () + _ -> Left (TypeError ctx e (CantMultiply l tl)) + + tr <- fmap Dhall.Core.normalize (typeWith ctx r) + case tr of + Natural -> return () + _ -> Left (TypeError ctx e (CantMultiply r tr)) + return Natural +typeWith _ Integer = do + return (Const Type) +typeWith _ (IntegerLit _ ) = do + return Integer +typeWith _ IntegerShow = do + return (Pi "_" Integer Text) +typeWith _ Double = do + return (Const Type) +typeWith _ (DoubleLit _ ) = do + return Double +typeWith _ DoubleShow = do + return (Pi "_" Double Text) +typeWith _ Text = do + return (Const Type) +typeWith _ (TextLit _ ) = do + return Text +typeWith ctx e@(TextAppend l r ) = do + tl <- fmap Dhall.Core.normalize (typeWith ctx l) + case tl of + Text -> return () + _ -> Left (TypeError ctx e (CantTextAppend l tl)) + + tr <- fmap Dhall.Core.normalize (typeWith ctx r) + case tr of + Text -> return () + _ -> Left (TypeError ctx e (CantTextAppend r tr)) + return Text +typeWith _ List = do + return (Pi "_" (Const Type) (Const Type)) +typeWith ctx e@(ListLit Nothing xs) = do + if Data.Vector.null xs + then Left (TypeError ctx e MissingListType) + else do + t <- typeWith ctx (Data.Vector.head xs) + s <- fmap Dhall.Core.normalize (typeWith ctx t) + case s of + Const Type -> return () + _ -> Left (TypeError ctx e (InvalidListType t)) + flip Data.Vector.imapM_ xs (\i x -> do + t' <- typeWith ctx x + if propEqual t t' + then return () + else do + let nf_t = Dhall.Core.normalize t + let nf_t' = Dhall.Core.normalize t' + let err = MismatchedListElements i nf_t x nf_t' + Left (TypeError ctx e err) ) + return (App List t) +typeWith ctx e@(ListLit (Just t ) xs) = do + s <- fmap Dhall.Core.normalize (typeWith ctx t) + case s of + Const Type -> return () + _ -> Left (TypeError ctx e (InvalidListType t)) + flip Data.Vector.imapM_ xs (\i x -> do + t' <- typeWith ctx x + if propEqual t t' + then return () + else do + let nf_t = Dhall.Core.normalize t + let nf_t' = Dhall.Core.normalize t' + Left (TypeError ctx e (InvalidListElement i nf_t x nf_t')) ) + return (App List t) +typeWith ctx e@(ListAppend l r ) = do + tl <- fmap Dhall.Core.normalize (typeWith ctx l) + el <- case tl of + App List el -> return el + _ -> Left (TypeError ctx e (CantListAppend l tl)) + + tr <- fmap Dhall.Core.normalize (typeWith ctx r) + er <- case tr of + App List er -> return er + _ -> Left (TypeError ctx e (CantListAppend r tr)) + + if propEqual el er + then return (App List el) + else Left (TypeError ctx e (ListAppendMismatch el er)) +typeWith _ ListBuild = do + return + (Pi "a" (Const Type) + (Pi "_" + (Pi "list" (Const Type) + (Pi "cons" (Pi "_" "a" (Pi "_" "list" "list")) + (Pi "nil" "list" "list") ) ) + (App List "a") ) ) +typeWith _ ListFold = do + return + (Pi "a" (Const Type) + (Pi "_" (App List "a") + (Pi "list" (Const Type) + (Pi "cons" (Pi "_" "a" (Pi "_" "list" "list")) + (Pi "nil" "list" "list")) ) ) ) +typeWith _ ListLength = do + return (Pi "a" (Const Type) (Pi "_" (App List "a") Natural)) +typeWith _ ListHead = do + return (Pi "a" (Const Type) (Pi "_" (App List "a") (App Optional "a"))) +typeWith _ ListLast = do + return (Pi "a" (Const Type) (Pi "_" (App List "a") (App Optional "a"))) +typeWith _ ListIndexed = do + let kts = [("index", Natural), ("value", "a")] + return + (Pi "a" (Const Type) + (Pi "_" (App List "a") + (App List (Record (Data.Map.fromList kts))) ) ) +typeWith _ ListReverse = do + return (Pi "a" (Const Type) (Pi "_" (App List "a") (App List "a"))) +typeWith _ Optional = do + return (Pi "_" (Const Type) (Const Type)) +typeWith ctx e@(OptionalLit t xs) = do + s <- fmap Dhall.Core.normalize (typeWith ctx t) + case s of + Const Type -> return () + _ -> Left (TypeError ctx e (InvalidOptionalType t)) + let n = Data.Vector.length xs + if 2 <= n + then Left (TypeError ctx e (InvalidOptionalLiteral n)) + else return () + forM_ xs (\x -> do + t' <- typeWith ctx x + if propEqual t t' + then return () + else do + let nf_t = Dhall.Core.normalize t + let nf_t' = Dhall.Core.normalize t' + Left (TypeError ctx e (InvalidOptionalElement nf_t x nf_t')) ) + return (App Optional t) +typeWith _ OptionalFold = do + return + (Pi "a" (Const Type) + (Pi "_" (App Optional "a") + (Pi "optional" (Const Type) + (Pi "just" (Pi "_" "a" "optional") + (Pi "nothing" "optional" "optional") ) ) ) ) +typeWith _ OptionalBuild = do + return + (Pi "a" (Const Type) + (Pi "_" f (App Optional "a") ) ) + where f = Pi "optional" (Const Type) + (Pi "just" (Pi "_" "a" "optional") + (Pi "nothing" "optional" "optional") ) +typeWith ctx e@(Record kts ) = do + let process (k, t) = do + s <- fmap Dhall.Core.normalize (typeWith ctx t) + case s of + Const Type -> return () + _ -> Left (TypeError ctx e (InvalidFieldType k t)) + mapM_ process (Data.Map.toList kts) + return (Const Type) +typeWith ctx e@(RecordLit kvs ) = do + let process (k, v) = do + t <- typeWith ctx v + s <- fmap Dhall.Core.normalize (typeWith ctx t) + case s of + Const Type -> return () + _ -> Left (TypeError ctx e (InvalidField k v)) + return (k, t) + kts <- mapM process (Data.Map.toAscList kvs) + return (Record (Data.Map.fromAscList kts)) +typeWith ctx e@(Union kts ) = do + let process (k, t) = do + s <- fmap Dhall.Core.normalize (typeWith ctx t) + case s of + Const Type -> return () + _ -> Left (TypeError ctx e (InvalidAlternativeType k t)) + mapM_ process (Data.Map.toList kts) + return (Const Type) +typeWith ctx e@(UnionLit k v kts) = do + case Data.Map.lookup k kts of + Just _ -> Left (TypeError ctx e (DuplicateAlternative k)) + Nothing -> return () + t <- typeWith ctx v + let union = Union (Data.Map.insert k t kts) + _ <- typeWith ctx union + return union +typeWith ctx e@(Combine kvsX kvsY) = do + tKvsX <- fmap Dhall.Core.normalize (typeWith ctx kvsX) + ktsX <- case tKvsX of + Record kts -> return kts + _ -> Left (TypeError ctx e (MustCombineARecord '∧' kvsX tKvsX)) + + tKvsY <- fmap Dhall.Core.normalize (typeWith ctx kvsY) + ktsY <- case tKvsY of + Record kts -> return kts + _ -> Left (TypeError ctx e (MustCombineARecord '∧' kvsY tKvsY)) + + let combineTypes ktsL ktsR = do + let ks = + Data.Set.union (Data.Map.keysSet ktsL) (Data.Map.keysSet ktsR) + kts <- forM (toList ks) (\k -> do + case (Data.Map.lookup k ktsL, Data.Map.lookup k ktsR) of + (Just (Record ktsL'), Just (Record ktsR')) -> do + t <- combineTypes ktsL' ktsR' + return (k, t) + (Nothing, Just t) -> do + return (k, t) + (Just t, Nothing) -> do + return (k, t) + _ -> do + Left (TypeError ctx e (FieldCollision k)) ) + return (Record (Data.Map.fromList kts)) + + combineTypes ktsX ktsY +typeWith ctx e@(Prefer kvsX kvsY) = do + tKvsX <- fmap Dhall.Core.normalize (typeWith ctx kvsX) + ktsX <- case tKvsX of + Record kts -> return kts + _ -> Left (TypeError ctx e (MustCombineARecord '⫽' kvsX tKvsX)) + + tKvsY <- fmap Dhall.Core.normalize (typeWith ctx kvsY) + ktsY <- case tKvsY of + Record kts -> return kts + _ -> Left (TypeError ctx e (MustCombineARecord '⫽' kvsY tKvsY)) + return (Record (Data.Map.union ktsY ktsX)) +typeWith ctx e@(Merge kvsX kvsY (Just t)) = do + tKvsX <- fmap Dhall.Core.normalize (typeWith ctx kvsX) + ktsX <- case tKvsX of + Record kts -> return kts + _ -> Left (TypeError ctx e (MustMergeARecord kvsX tKvsX)) + let ksX = Data.Map.keysSet ktsX + + tKvsY <- fmap Dhall.Core.normalize (typeWith ctx kvsY) + ktsY <- case tKvsY of + Union kts -> return kts + _ -> Left (TypeError ctx e (MustMergeUnion kvsY tKvsY)) + let ksY = Data.Map.keysSet ktsY + + let diffX = Data.Set.difference ksX ksY + let diffY = Data.Set.difference ksY ksX + + if Data.Set.null diffX + then return () + else Left (TypeError ctx e (UnusedHandler diffX)) + + let process (kY, tY) = do + case Data.Map.lookup kY ktsX of + Nothing -> Left (TypeError ctx e (MissingHandler diffY)) + Just tX -> + case tX of + Pi _ tY' t' -> do + if propEqual tY tY' + then return () + else Left (TypeError ctx e (HandlerInputTypeMismatch kY tY tY')) + if propEqual t t' + then return () + else Left (TypeError ctx e (InvalidHandlerOutputType kY t t')) + _ -> Left (TypeError ctx e (HandlerNotAFunction kY tX)) + mapM_ process (Data.Map.toList ktsY) + return t +typeWith ctx e@(Merge kvsX kvsY Nothing) = do + tKvsX <- fmap Dhall.Core.normalize (typeWith ctx kvsX) + ktsX <- case tKvsX of + Record kts -> return kts + _ -> Left (TypeError ctx e (MustMergeARecord kvsX tKvsX)) + let ksX = Data.Map.keysSet ktsX + + tKvsY <- fmap Dhall.Core.normalize (typeWith ctx kvsY) + ktsY <- case tKvsY of + Union kts -> return kts + _ -> Left (TypeError ctx e (MustMergeUnion kvsY tKvsY)) + let ksY = Data.Map.keysSet ktsY + + let diffX = Data.Set.difference ksX ksY + let diffY = Data.Set.difference ksY ksX + + if Data.Set.null diffX + then return () + else Left (TypeError ctx e (UnusedHandler diffX)) + + (kX, t) <- case Data.Map.assocs ktsX of + [] -> Left (TypeError ctx e MissingMergeType) + (kX, Pi _ _ t):_ -> return (kX, t) + (kX, tX ):_ -> Left (TypeError ctx e (HandlerNotAFunction kX tX)) + let process (kY, tY) = do + case Data.Map.lookup kY ktsX of + Nothing -> Left (TypeError ctx e (MissingHandler diffY)) + Just tX -> + case tX of + Pi _ tY' t' -> do + if propEqual tY tY' + then return () + else Left (TypeError ctx e (HandlerInputTypeMismatch kY tY tY')) + if propEqual t t' + then return () + else Left (TypeError ctx e (HandlerOutputTypeMismatch kX t kY t')) + _ -> Left (TypeError ctx e (HandlerNotAFunction kY tX)) + mapM_ process (Data.Map.toList ktsY) + return t +typeWith ctx e@(Field r x ) = do + t <- fmap Dhall.Core.normalize (typeWith ctx r) + case t of + Record kts -> + case Data.Map.lookup x kts of + Just t' -> return t' + Nothing -> Left (TypeError ctx e (MissingField x t)) + _ -> Left (TypeError ctx e (NotARecord x r t)) +typeWith ctx (Note s e' ) = case typeWith ctx e' of + Left (TypeError ctx' (Note s' e'') m) -> Left (TypeError ctx' (Note s' e'') m) + Left (TypeError ctx' e'' m) -> Left (TypeError ctx' (Note s e'') m) + Right r -> Right r +typeWith _ (Embed p ) = do + absurd p + +{-| `typeOf` is the same as `typeWith` with an empty context, meaning that the + expression must be closed (i.e. no free variables), otherwise type-checking + will fail. +-} +typeOf :: Expr s X -> Either (TypeError s) (Expr s X) +typeOf = typeWith Dhall.Context.empty + +-- | Like `Data.Void.Void`, except with a shorter inferred type +newtype X = X { absurd :: forall a . a } + +instance Show X where + show = absurd + +instance Eq X where + _ == _ = True + +instance Buildable X where + build = absurd + +-- | The specific type error +data TypeMessage s + = UnboundVariable + | InvalidInputType (Expr s X) + | InvalidOutputType (Expr s X) + | NotAFunction (Expr s X) (Expr s X) + | TypeMismatch (Expr s X) (Expr s X) (Expr s X) (Expr s X) + | AnnotMismatch (Expr s X) (Expr s X) (Expr s X) + | Untyped + | MissingListType + | MismatchedListElements Int (Expr s X) (Expr s X) (Expr s X) + | InvalidListElement Int (Expr s X) (Expr s X) (Expr s X) + | InvalidListType (Expr s X) + | InvalidOptionalElement (Expr s X) (Expr s X) (Expr s X) + | InvalidOptionalLiteral Int + | InvalidOptionalType (Expr s X) + | InvalidPredicate (Expr s X) (Expr s X) + | IfBranchMismatch (Expr s X) (Expr s X) (Expr s X) (Expr s X) + | IfBranchMustBeTerm Bool (Expr s X) (Expr s X) (Expr s X) + | InvalidField Text (Expr s X) + | InvalidFieldType Text (Expr s X) + | InvalidAlternative Text (Expr s X) + | InvalidAlternativeType Text (Expr s X) + | ListAppendMismatch (Expr s X) (Expr s X) + | DuplicateAlternative Text + | MustCombineARecord Char (Expr s X) (Expr s X) + | FieldCollision Text + | MustMergeARecord (Expr s X) (Expr s X) + | MustMergeUnion (Expr s X) (Expr s X) + | UnusedHandler (Set Text) + | MissingHandler (Set Text) + | HandlerInputTypeMismatch Text (Expr s X) (Expr s X) + | HandlerOutputTypeMismatch Text (Expr s X) Text (Expr s X) + | InvalidHandlerOutputType Text (Expr s X) (Expr s X) + | MissingMergeType + | HandlerNotAFunction Text (Expr s X) + | NotARecord Text (Expr s X) (Expr s X) + | MissingField Text (Expr s X) + | CantAnd (Expr s X) (Expr s X) + | CantOr (Expr s X) (Expr s X) + | CantEQ (Expr s X) (Expr s X) + | CantNE (Expr s X) (Expr s X) + | CantTextAppend (Expr s X) (Expr s X) + | CantListAppend (Expr s X) (Expr s X) + | CantAdd (Expr s X) (Expr s X) + | CantMultiply (Expr s X) (Expr s X) + | NoDependentLet (Expr s X) (Expr s X) + | NoDependentTypes (Expr s X) (Expr s X) + deriving (Show) + +shortTypeMessage :: TypeMessage s -> Builder +shortTypeMessage msg = + "\ESC[1;31mError\ESC[0m: " <> build short <> "\n" + where + ErrorMessages {..} = prettyTypeMessage msg + +longTypeMessage :: TypeMessage s -> Builder +longTypeMessage msg = + "\ESC[1;31mError\ESC[0m: " <> build short <> "\n" + <> "\n" + <> long + where + ErrorMessages {..} = prettyTypeMessage msg + +data ErrorMessages = ErrorMessages + { short :: Builder + -- ^ Default succinct 1-line explanation of what went wrong + , long :: Builder + -- ^ Longer and more detailed explanation of the error + } + +_NOT :: Builder +_NOT = "\ESC[1mnot\ESC[0m" + +prettyTypeMessage :: TypeMessage s -> ErrorMessages +prettyTypeMessage UnboundVariable = ErrorMessages {..} + where + short = "Unbound variable" + + long = + "Explanation: Expressions can only reference previously introduced (i.e. \"bound\")\n\ + \variables that are still \"in scope\" \n\ + \ \n\ + \For example, the following valid expressions introduce a \"bound\" variable named\n\ + \❰x❱: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────┐ \n\ + \ │ λ(x : Bool) → x │ Anonymous functions introduce \"bound\" variables \n\ + \ └─────────────────┘ \n\ + \ ⇧ \n\ + \ This is the bound variable \n\ + \ \n\ + \ \n\ + \ ┌─────────────────┐ \n\ + \ │ let x = 1 in x │ ❰let❱ expressions introduce \"bound\" variables \n\ + \ └─────────────────┘ \n\ + \ ⇧ \n\ + \ This is the bound variable \n\ + \ \n\ + \ \n\ + \However, the following expressions are not valid because they all reference a \n\ + \variable that has not been introduced yet (i.e. an \"unbound\" variable): \n\ + \ \n\ + \ \n\ + \ ┌─────────────────┐ \n\ + \ │ λ(x : Bool) → y │ The variable ❰y❱ hasn't been introduced yet \n\ + \ └─────────────────┘ \n\ + \ ⇧ \n\ + \ This is the unbound variable \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────┐ \n\ + \ │ (let x = True in x) && x │ ❰x❱ is undefined outside the parentheses \n\ + \ └──────────────────────────┘ \n\ + \ ⇧ \n\ + \ This is the unbound variable \n\ + \ \n\ + \ \n\ + \ ┌────────────────┐ \n\ + \ │ let x = x in x │ The definition for ❰x❱ cannot reference itself \n\ + \ └────────────────┘ \n\ + \ ⇧ \n\ + \ This is the unbound variable \n\ + \ \n\ + \ \n\ + \Some common reasons why you might get this error: \n\ + \ \n\ + \● You misspell a variable name, like this: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────────────────────────────────┐ \n\ + \ │ λ(empty : Bool) → if emty then \"Empty\" else \"Full\" │ \n\ + \ └────────────────────────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ Typo \n\ + \ \n\ + \ \n\ + \● You misspell a reserved identifier, like this: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────┐ \n\ + \ │ foral (a : Type) → a → a │ \n\ + \ └──────────────────────────┘ \n\ + \ ⇧ \n\ + \ Typo \n\ + \ \n\ + \ \n\ + \● You tried to define a recursive value, like this: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────┐ \n\ + \ │ let x = x + +1 in x │ \n\ + \ └─────────────────────┘ \n\ + \ ⇧ \n\ + \ Recursive definitions are not allowed \n\ + \ \n\ + \ \n\ + \● You accidentally forgot a ❰λ❱ or ❰∀❱/❰forall❱ \n\ + \ \n\ + \ \n\ + \ Unbound variable \n\ + \ ⇩ \n\ + \ ┌─────────────────┐ \n\ + \ │ (x : Bool) → x │ \n\ + \ └─────────────────┘ \n\ + \ ⇧ \n\ + \ A ❰λ❱ here would transform this into a valid anonymous function \n\ + \ \n\ + \ \n\ + \ Unbound variable \n\ + \ ⇩ \n\ + \ ┌────────────────────┐ \n\ + \ │ (x : Bool) → Bool │ \n\ + \ └────────────────────┘ \n\ + \ ⇧ \n\ + \ A ❰∀❱ or ❰forall❱ here would transform this into a valid function type \n" + +prettyTypeMessage (InvalidInputType expr) = ErrorMessages {..} + where + short = "Invalid function input" + + long = + "Explanation: A function can accept an input \"term\" that has a given \"type\", like\n\ + \this: \n\ + \ \n\ + \ \n\ + \ This is the input term that the function accepts \n\ + \ ⇩ \n\ + \ ┌───────────────────────┐ \n\ + \ │ ∀(x : Natural) → Bool │ This is the type of a function that accepts an \n\ + \ └───────────────────────┘ input term named ❰x❱ that has type ❰Natural❱ \n\ + \ ⇧ \n\ + \ This is the type of the input term \n\ + \ \n\ + \ \n\ + \ ┌────────────────┐ \n\ + \ │ Bool → Integer │ This is the type of a function that accepts an anonymous\n\ + \ └────────────────┘ input term that has type ❰Bool❱ \n\ + \ ⇧ \n\ + \ This is the type of the input term \n\ + \ \n\ + \ \n\ + \... or a function can accept an input \"type\" that has a given \"kind\", like this:\n\ + \ \n\ + \ \n\ + \ This is the input type that the function accepts \n\ + \ ⇩ \n\ + \ ┌────────────────────┐ \n\ + \ │ ∀(a : Type) → Type │ This is the type of a function that accepts an input\n\ + \ └────────────────────┘ type named ❰a❱ that has kind ❰Type❱ \n\ + \ ⇧ \n\ + \ This is the kind of the input type \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────┐ \n\ + \ │ (Type → Type) → Type │ This is the type of a function that accepts an \n\ + \ └──────────────────────┘ anonymous input type that has kind ❰Type → Type❱ \n\ + \ ⇧ \n\ + \ This is the kind of the input type \n\ + \ \n\ + \ \n\ + \Other function inputs are " <> _NOT <> " valid, like this: \n\ + \ \n\ + \ \n\ + \ ┌──────────────┐ \n\ + \ │ ∀(x : 1) → x │ ❰1❱ is a \"term\" and not a \"type\" nor a \"kind\" so ❰x❱\n\ + \ └──────────────┘ cannot have \"type\" ❰1❱ or \"kind\" ❰1❱ \n\ + \ ⇧ \n\ + \ This is not a type or kind \n\ + \ \n\ + \ \n\ + \ ┌──────────┐ \n\ + \ │ True → x │ ❰True❱ is a \"term\" and not a \"type\" nor a \"kind\" so the \n\ + \ └──────────┘ anonymous input cannot have \"type\" ❰True❱ or \"kind\" ❰True❱\n\ + \ ⇧ \n\ + \ This is not a type or kind \n\ + \ \n\ + \ \n\ + \You annotated a function input with the following expression: \n\ + \ \n\ + \↳ " <> txt <> " \n\ + \ \n\ + \... which is neither a type nor a kind \n" + where + txt = build expr + +prettyTypeMessage (InvalidOutputType expr) = ErrorMessages {..} + where + short = "Invalid function output" + + long = + "Explanation: A function can return an output \"term\" that has a given \"type\",\n\ + \like this: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────┐ \n\ + \ │ ∀(x : Text) → Bool │ This is the type of a function that returns an \n\ + \ └────────────────────┘ output term that has type ❰Bool❱ \n\ + \ ⇧ \n\ + \ This is the type of the output term \n\ + \ \n\ + \ \n\ + \ ┌────────────────┐ \n\ + \ │ Bool → Integer │ This is the type of a function that returns an output \n\ + \ └────────────────┘ term that has type ❰Int❱ \n\ + \ ⇧ \n\ + \ This is the type of the output term \n\ + \ \n\ + \ \n\ + \... or a function can return an output \"type\" that has a given \"kind\", like \n\ + \this: \n\ + \ \n\ + \ ┌────────────────────┐ \n\ + \ │ ∀(a : Type) → Type │ This is the type of a function that returns an \n\ + \ └────────────────────┘ output type that has kind ❰Type❱ \n\ + \ ⇧ \n\ + \ This is the kind of the output type \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────┐ \n\ + \ │ (Type → Type) → Type │ This is the type of a function that returns an \n\ + \ └──────────────────────┘ output type that has kind ❰Type❱ \n\ + \ ⇧ \n\ + \ This is the kind of the output type \n\ + \ \n\ + \ \n\ + \Other outputs are " <> _NOT <> " valid, like this: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────┐ \n\ + \ │ ∀(x : Bool) → x │ ❰x❱ is a \"term\" and not a \"type\" nor a \"kind\" so the\n\ + \ └─────────────────┘ output cannot have \"type\" ❰x❱ or \"kind\" ❰x❱ \n\ + \ ⇧ \n\ + \ This is not a type or kind \n\ + \ \n\ + \ \n\ + \ ┌─────────────┐ \n\ + \ │ Text → True │ ❰True❱ is a \"term\" and not a \"type\" nor a \"kind\" so the\n\ + \ └─────────────┘ output cannot have \"type\" ❰True❱ or \"kind\" ❰True❱ \n\ + \ ⇧ \n\ + \ This is not a type or kind \n\ + \ \n\ + \ \n\ + \Some common reasons why you might get this error: \n\ + \ \n\ + \● You use ❰∀❱ instead of ❰λ❱ by mistake, like this: \n\ + \ \n\ + \ \n\ + \ ┌────────────────┐ \n\ + \ │ ∀(x: Bool) → x │ \n\ + \ └────────────────┘ \n\ + \ ⇧ \n\ + \ Using ❰λ❱ here instead of ❰∀❱ would transform this into a valid function \n\ + \ \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \You specified that your function outputs a: \n\ + \ \n\ + \↳ " <> txt <> " \n\ + \ \n\ + \... which is neither a type nor a kind: \n" + where + txt = build expr + +prettyTypeMessage (NotAFunction expr0 expr1) = ErrorMessages {..} + where + short = "Not a function" + + long = + "Explanation: Expressions separated by whitespace denote function application, \n\ + \like this: \n\ + \ \n\ + \ \n\ + \ ┌─────┐ \n\ + \ │ f x │ This denotes the function ❰f❱ applied to an argument named ❰x❱ \n\ + \ └─────┘ \n\ + \ \n\ + \ \n\ + \A function is a term that has type ❰a → b❱ for some ❰a❱ or ❰b❱. For example, \n\ + \the following expressions are all functions because they have a function type: \n\ + \ \n\ + \ \n\ + \ The function's input type is ❰Bool❱ \n\ + \ ⇩ \n\ + \ ┌───────────────────────────────┐ \n\ + \ │ λ(x : Bool) → x : Bool → Bool │ User-defined anonymous function \n\ + \ └───────────────────────────────┘ \n\ + \ ⇧ \n\ + \ The function's output type is ❰Bool❱ \n\ + \ \n\ + \ \n\ + \ The function's input type is ❰Natural❱ \n\ + \ ⇩ \n\ + \ ┌───────────────────────────────┐ \n\ + \ │ Natural/even : Natural → Bool │ Built-in function \n\ + \ └───────────────────────────────┘ \n\ + \ ⇧ \n\ + \ The function's output type is ❰Bool❱ \n\ + \ \n\ + \ \n\ + \ The function's input kind is ❰Type❱ \n\ + \ ⇩ \n\ + \ ┌───────────────────────────────┐ \n\ + \ │ λ(a : Type) → a : Type → Type │ Type-level functions are still functions \n\ + \ └───────────────────────────────┘ \n\ + \ ⇧ \n\ + \ The function's output kind is ❰Type❱ \n\ + \ \n\ + \ \n\ + \ The function's input kind is ❰Type❱ \n\ + \ ⇩ \n\ + \ ┌────────────────────┐ \n\ + \ │ List : Type → Type │ Built-in type-level function \n\ + \ └────────────────────┘ \n\ + \ ⇧ \n\ + \ The function's output kind is ❰Type❱ \n\ + \ \n\ + \ \n\ + \ Function's input has kind ❰Type❱ \n\ + \ ⇩ \n\ + \ ┌─────────────────────────────────────────────────┐ \n\ + \ │ List/head : ∀(a : Type) → (List a → Optional a) │ A function can return \n\ + \ └─────────────────────────────────────────────────┘ another function \n\ + \ ⇧ \n\ + \ Function's output has type ❰List a → Optional a❱\n\ + \ \n\ + \ \n\ + \ The function's input type is ❰List Text❱ \n\ + \ ⇩ \n\ + \ ┌────────────────────────────────────────────┐ \n\ + \ │ List/head Text : List Text → Optional Text │ A function applied to an \n\ + \ └────────────────────────────────────────────┘ argument can be a function \n\ + \ ⇧ \n\ + \ The function's output type is ❰Optional Text❱\n\ + \ \n\ + \ \n\ + \An expression is not a function if the expression's type is not of the form \n\ + \❰a → b❱. For example, these are " <> _NOT <> " functions: \n\ + \ \n\ + \ \n\ + \ ┌─────────────┐ \n\ + \ │ 1 : Integer │ ❰1❱ is not a function because ❰Integer❱ is not the type of \n\ + \ └─────────────┘ a function \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────┐ \n\ + \ │ Natural/even +2 : Bool │ ❰Natural/even +2❱ is not a function because \n\ + \ └────────────────────────┘ ❰Bool❱ is not the type of a function \n\ + \ \n\ + \ \n\ + \ ┌──────────────────┐ \n\ + \ │ List Text : Type │ ❰List Text❱ is not a function because ❰Type❱ is not \n\ + \ └──────────────────┘ the type of a function \n\ + \ \n\ + \ \n\ + \Some common reasons why you might get this error: \n\ + \ \n\ + \● You tried to add two ❰Integer❱s without a space around the ❰+❱, like this: \n\ + \ \n\ + \ \n\ + \ ┌─────┐ \n\ + \ │ 2+2 │ \n\ + \ └─────┘ \n\ + \ \n\ + \ \n\ + \ The above code is parsed as: \n\ + \ \n\ + \ \n\ + \ ┌────────┐ \n\ + \ │ 2 (+2) │ \n\ + \ └────────┘ \n\ + \ ⇧ \n\ + \ The compiler thinks that this ❰2❱ is a function whose argument is ❰+2❱ \n\ + \ \n\ + \ \n\ + \ This is because the ❰+❱ symbol has two meanings: you use ❰+❱ to add two \n\ + \ numbers, but you also can prefix ❰Integer❱ literals with a ❰+❱ to turn them \n\ + \ into ❰Natural❱ literals (like ❰+2❱) \n\ + \ \n\ + \ To fix the code, you need to put spaces around the ❰+❱ and also prefix each \n\ + \ ❰2❱ with a ❰+❱, like this: \n\ + \ \n\ + \ \n\ + \ ┌─────────┐ \n\ + \ │ +2 + +2 │ \n\ + \ └─────────┘ \n\ + \ \n\ + \ \n\ + \ You can only add ❰Natural❱ numbers, which is why you must also change each \n\ + \ ❰2❱ to ❰+2❱ \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \You tried to use the following expression as a function: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... but this expression's type is: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... which is not a function type \n" + where + txt0 = build expr0 + txt1 = build expr1 + +prettyTypeMessage (TypeMismatch expr0 expr1 expr2 expr3) = ErrorMessages {..} + where + short = "Wrong type of function argument" + + long = + "Explanation: Every function declares what type or kind of argument to accept \n\ + \ \n\ + \For example: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────┐ \n\ + \ │ λ(x : Bool) → x : Bool → Bool │ This anonymous function only accepts \n\ + \ └───────────────────────────────┘ arguments that have type ❰Bool❱ \n\ + \ ⇧ \n\ + \ The function's input type \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────┐ \n\ + \ │ Natural/even : Natural → Bool │ This built-in function only accepts \n\ + \ └───────────────────────────────┘ arguments that have type ❰Natural❱ \n\ + \ ⇧ \n\ + \ The function's input type \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────┐ \n\ + \ │ λ(a : Type) → a : Type → Type │ This anonymous function only accepts \n\ + \ └───────────────────────────────┘ arguments that have kind ❰Type❱ \n\ + \ ⇧ \n\ + \ The function's input kind \n\ + \ \n\ + \ \n\ + \ ┌────────────────────┐ \n\ + \ │ List : Type → Type │ This built-in function only accepts arguments that \n\ + \ └────────────────────┘ have kind ❰Type❱ \n\ + \ ⇧ \n\ + \ The function's input kind \n\ + \ \n\ + \ \n\ + \For example, the following expressions are valid: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────┐ \n\ + \ │ (λ(x : Bool) → x) True │ ❰True❱ has type ❰Bool❱, which matches the type \n\ + \ └────────────────────────┘ of argument that the anonymous function accepts \n\ + \ \n\ + \ \n\ + \ ┌─────────────────┐ \n\ + \ │ Natural/even +2 │ ❰+2❱ has type ❰Natural❱, which matches the type of \n\ + \ └─────────────────┘ argument that the ❰Natural/even❱ function accepts, \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────┐ \n\ + \ │ (λ(a : Type) → a) Bool │ ❰Bool❱ has kind ❰Type❱, which matches the kind \n\ + \ └────────────────────────┘ of argument that the anonymous function accepts \n\ + \ \n\ + \ \n\ + \ ┌───────────┐ \n\ + \ │ List Text │ ❰Text❱ has kind ❰Type❱, which matches the kind of argument \n\ + \ └───────────┘ that that the ❰List❱ function accepts \n\ + \ \n\ + \ \n\ + \However, you can " <> _NOT <> " apply a function to the wrong type or kind of argument\n\ + \ \n\ + \For example, the following expressions are not valid: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────┐ \n\ + \ │ (λ(x : Bool) → x) \"A\" │ ❰\"A\"❱ has type ❰Text❱, but the anonymous function\n\ + \ └───────────────────────┘ expects an argument that has type ❰Bool❱ \n\ + \ \n\ + \ \n\ + \ ┌──────────────────┐ \n\ + \ │ Natural/even \"A\" │ ❰\"A\"❱ has type ❰Text❱, but the ❰Natural/even❱ function\n\ + \ └──────────────────┘ expects an argument that has type ❰Natural❱ \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────┐ \n\ + \ │ (λ(a : Type) → a) True │ ❰True❱ has type ❰Bool❱, but the anonymous \n\ + \ └────────────────────────┘ function expects an argument of kind ❰Type❱ \n\ + \ \n\ + \ \n\ + \ ┌────────┐ \n\ + \ │ List 1 │ ❰1❱ has type ❰Integer❱, but the ❰List❱ function expects an \n\ + \ └────────┘ argument that has kind ❰Type❱ \n\ + \ \n\ + \ \n\ + \Some common reasons why you might get this error: \n\ + \ \n\ + \● You omit a function argument by mistake: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────┐ \n\ + \ │ List/head [1, 2, 3] │ \n\ + \ └───────────────────────┘ \n\ + \ ⇧ \n\ + \ ❰List/head❱ is missing the first argument, \n\ + \ which should be: ❰Integer❱ \n\ + \ \n\ + \ \n\ + \● You supply an ❰Integer❱ literal to a function that expects a ❰Natural❱ \n\ + \ \n\ + \ \n\ + \ ┌────────────────┐ \n\ + \ │ Natural/even 2 │ \n\ + \ └────────────────┘ \n\ + \ ⇧ \n\ + \ This should be ❰+2❱ \n\ + \ \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \You tried to invoke the following function: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... which expects an argument of type or kind: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... on the following argument: \n\ + \ \n\ + \↳ " <> txt2 <> " \n\ + \ \n\ + \... which has a different type or kind: \n\ + \ \n\ + \↳ " <> txt3 <> " \n" + where + txt0 = build expr0 + txt1 = build expr1 + txt2 = build expr2 + txt3 = build expr3 + +prettyTypeMessage (AnnotMismatch expr0 expr1 expr2) = ErrorMessages {..} + where + short = "Expression doesn't match annotation" + + long = + "Explanation: You can annotate an expression with its type or kind using the \n\ + \❰:❱ symbol, like this: \n\ + \ \n\ + \ \n\ + \ ┌───────┐ \n\ + \ │ x : t │ ❰x❱ is an expression and ❰t❱ is the annotated type or kind of ❰x❱\n\ + \ └───────┘ \n\ + \ \n\ + \The type checker verifies that the expression's type or kind matches the \n\ + \provided annotation \n\ + \ \n\ + \For example, all of the following are valid annotations that the type checker \n\ + \accepts: \n\ + \ \n\ + \ \n\ + \ ┌─────────────┐ \n\ + \ │ 1 : Integer │ ❰1❱ is an expression that has type ❰Integer❱, so the type \n\ + \ └─────────────┘ checker accepts the annotation \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────┐ \n\ + \ │ Natural/even +2 : Bool │ ❰Natural/even +2❱ has type ❰Bool❱, so the type \n\ + \ └────────────────────────┘ checker accepts the annotation \n\ + \ \n\ + \ \n\ + \ ┌────────────────────┐ \n\ + \ │ List : Type → Type │ ❰List❱ is an expression that has kind ❰Type → Type❱,\n\ + \ └────────────────────┘ so the type checker accepts the annotation \n\ + \ \n\ + \ \n\ + \ ┌──────────────────┐ \n\ + \ │ List Text : Type │ ❰List Text❱ is an expression that has kind ❰Type❱, so \n\ + \ └──────────────────┘ the type checker accepts the annotation \n\ + \ \n\ + \ \n\ + \However, the following annotations are " <> _NOT <> " valid and the type checker will\n\ + \reject them: \n\ + \ \n\ + \ \n\ + \ ┌──────────┐ \n\ + \ │ 1 : Text │ The type checker rejects this because ❰1❱ does not have type \n\ + \ └──────────┘ ❰Text❱ \n\ + \ \n\ + \ \n\ + \ ┌─────────────┐ \n\ + \ │ List : Type │ ❰List❱ does not have kind ❰Type❱ \n\ + \ └─────────────┘ \n\ + \ \n\ + \ \n\ + \Some common reasons why you might get this error: \n\ + \ \n\ + \● The Haskell Dhall interpreter implicitly inserts a top-level annotation \n\ + \ matching the expected type \n\ + \ \n\ + \ For example, if you run the following Haskell code: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────┐ \n\ + \ │ >>> input auto \"1\" :: IO Text │ \n\ + \ └───────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \ ... then the interpreter will actually type check the following annotated \n\ + \ expression: \n\ + \ \n\ + \ \n\ + \ ┌──────────┐ \n\ + \ │ 1 : Text │ \n\ + \ └──────────┘ \n\ + \ \n\ + \ \n\ + \ ... and then type-checking will fail \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \You or the interpreter annotated this expression: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... with this type or kind: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... but the inferred type or kind of the expression is actually: \n\ + \ \n\ + \↳ " <> txt2 <> " \n" + where + txt0 = build expr0 + txt1 = build expr1 + txt2 = build expr2 + +prettyTypeMessage Untyped = ErrorMessages {..} + where + short = "❰Kind❱ has no type or kind" + + long = + "Explanation: There are four levels of expressions that form a heirarchy: \n\ + \ \n\ + \● terms \n\ + \● types \n\ + \● kinds \n\ + \● sorts \n\ + \ \n\ + \The following example illustrates this heirarchy: \n\ + \ \n\ + \ ┌────────────────────────────┐ \n\ + \ │ \"ABC\" : Text : Type : Kind │ \n\ + \ └────────────────────────────┘ \n\ + \ ⇧ ⇧ ⇧ ⇧ \n\ + \ term type kind sort \n\ + \ \n\ + \There is nothing above ❰Kind❱ in this hierarchy, so if you try to type check any\n\ + \expression containing ❰Kind❱ anywhere in the expression then type checking fails\n\ + \ \n\ + \Some common reasons why you might get this error: \n\ + \ \n\ + \● You supplied a kind where a type was expected \n\ + \ \n\ + \ For example, the following expression will fail to type check: \n\ + \ \n\ + \ ┌────────────────┐ \n\ + \ │ [] : List Type │ \n\ + \ └────────────────┘ \n\ + \ ⇧ \n\ + \ ❰Type❱ is a kind, not a type \n" + +prettyTypeMessage (InvalidPredicate expr0 expr1) = ErrorMessages {..} + where + short = "Invalid predicate for ❰if❱" + + long = + "Explanation: Every ❰if❱ expression begins with a predicate which must have type \n\ + \❰Bool❱ \n\ + \ \n\ + \For example, these are valid ❰if❱ expressions: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────────┐ \n\ + \ │ if True then \"Yes\" else \"No\" │ \n\ + \ └──────────────────────────────┘ \n\ + \ ⇧ \n\ + \ Predicate \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────┐ \n\ + \ │ λ(x : Bool) → if x then False else True │ \n\ + \ └─────────────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ Predicate \n\ + \ \n\ + \ \n\ + \... but these are " <> _NOT <> " valid ❰if❱ expressions: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────┐ \n\ + \ │ if 0 then \"Yes\" else \"No\" │ ❰0❱ does not have type ❰Bool❱ \n\ + \ └───────────────────────────┘ \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────────┐ \n\ + \ │ if \"\" then False else True │ ❰\"\"❱ does not have type ❰Bool❱ \n\ + \ └────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \Some common reasons why you might get this error: \n\ + \ \n\ + \● You might be used to other programming languages that accept predicates other \n\ + \ than ❰Bool❱ \n\ + \ \n\ + \ For example, some languages permit ❰0❱ or ❰\"\"❱ as valid predicates and treat\n\ + \ them as equivalent to ❰False❱. However, the Dhall language does not permit \n\ + \ this \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \Your ❰if❱ expression begins with the following predicate: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... that has type: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... but the predicate must instead have type ❰Bool❱ \n" + where + txt0 = build expr0 + txt1 = build expr1 + +prettyTypeMessage (IfBranchMustBeTerm b expr0 expr1 expr2) = + ErrorMessages {..} + where + short = "❰if❱ branch is not a term" + + long = + "Explanation: Every ❰if❱ expression has a ❰then❱ and ❰else❱ branch, each of which\n\ + \is an expression: \n\ + \ \n\ + \ \n\ + \ Expression for ❰then❱ branch \n\ + \ ⇩ \n\ + \ ┌────────────────────────────────┐ \n\ + \ │ if True then \"Hello, world!\" │ \n\ + \ │ else \"Goodbye, world!\" │ \n\ + \ └────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ Expression for ❰else❱ branch \n\ + \ \n\ + \ \n\ + \These expressions must be a \"term\", where a \"term\" is defined as an expression\n\ + \that has a type thas has kind ❰Type❱ \n\ + \ \n\ + \For example, the following expressions are all valid \"terms\": \n\ + \ \n\ + \ \n\ + \ ┌────────────────────┐ \n\ + \ │ 1 : Integer : Type │ ❰1❱ is a term with a type (❰Integer❱) of kind ❰Type❱\n\ + \ └────────────────────┘ \n\ + \ ⇧ \n\ + \ term \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────┐ \n\ + \ │ Natural/odd : Natural → Bool : Type │ ❰Natural/odd❱ is a term with a type\n\ + \ └─────────────────────────────────────┘ (❰Natural → Bool❱) of kind ❰Type❱ \n\ + \ ⇧ \n\ + \ term \n\ + \ \n\ + \ \n\ + \However, the following expressions are " <> _NOT <> " valid terms: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────┐ \n\ + \ │ Text : Type : Kind │ ❰Text❱ has kind (❰Type❱) of sort ❰Kind❱ and is \n\ + \ └────────────────────┘ therefore not a term \n\ + \ ⇧ \n\ + \ type \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────┐ \n\ + \ │ List : Type → Type : Kind │ ❰List❱ has kind (❰Type → Type❱) of sort \n\ + \ └───────────────────────────┘ ❰Kind❱ and is therefore not a term \n\ + \ ⇧ \n\ + \ type-level function \n\ + \ \n\ + \ \n\ + \This means that you cannot define an ❰if❱ expression that returns a type. For \n\ + \example, the following ❰if❱ expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────┐ \n\ + \ │ if True then Text else Bool │ Invalid ❰if❱ expression \n\ + \ └─────────────────────────────┘ \n\ + \ ⇧ ⇧ \n\ + \ type type \n\ + \ \n\ + \ \n\ + \Your ❰" <> txt0 <> "❱ branch of your ❰if❱ expression is: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... which has kind: \n\ + \ \n\ + \↳ " <> txt2 <> " \n\ + \ \n\ + \... of sort: \n\ + \ \n\ + \↳ " <> txt3 <> " \n\ + \ \n\ + \... and is not a term. Therefore your ❰if❱ expression is not valid \n" + where + txt0 = if b then "then" else "else" + txt1 = build expr0 + txt2 = build expr1 + txt3 = build expr2 + +prettyTypeMessage (IfBranchMismatch expr0 expr1 expr2 expr3) = + ErrorMessages {..} + where + short = "❰if❱ branches must have matching types" + + long = + "Explanation: Every ❰if❱ expression has a ❰then❱ and ❰else❱ branch, each of which\n\ + \is an expression: \n\ + \ \n\ + \ \n\ + \ Expression for ❰then❱ branch \n\ + \ ⇩ \n\ + \ ┌────────────────────────────────┐ \n\ + \ │ if True then \"Hello, world!\" │ \n\ + \ │ else \"Goodbye, world!\" │ \n\ + \ └────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ Expression for ❰else❱ branch \n\ + \ \n\ + \ \n\ + \These two expressions must have the same type. For example, the following ❰if❱ \n\ + \expressions are all valid: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────────────┐ \n\ + \ │ λ(b : Bool) → if b then 0 else 1 │ Both branches have type ❰Integer❱ \n\ + \ └──────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────────┐ \n\ + \ │ λ(b : Bool) → │ \n\ + \ │ if b then Natural/even │ Both branches have type ❰Natural → Bool❱ \n\ + \ │ else Natural/odd │ \n\ + \ └────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \However, the following expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ This branch has type ❰Integer❱ \n\ + \ ⇩ \n\ + \ ┌────────────────────────┐ \n\ + \ │ if True then 0 │ \n\ + \ │ else \"ABC\" │ \n\ + \ └────────────────────────┘ \n\ + \ ⇧ \n\ + \ This branch has type ❰Text❱ \n\ + \ \n\ + \ \n\ + \The ❰then❱ and ❰else❱ branches must have matching types, even if the predicate \n\ + \is always ❰True❱ or ❰False❱ \n\ + \ \n\ + \Your ❰if❱ expression has the following ❰then❱ branch: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... which has type: \n\ + \ \n\ + \↳ " <> txt2 <> " \n\ + \ \n\ + \... and the following ❰else❱ branch: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... which has a different type: \n\ + \ \n\ + \↳ " <> txt3 <> " \n\ + \ \n\ + \Fix your ❰then❱ and ❰else❱ branches to have matching types \n" + where + txt0 = build expr0 + txt1 = build expr1 + txt2 = build expr2 + txt3 = build expr3 + +prettyTypeMessage (InvalidListType expr0) = ErrorMessages {..} + where + short = "Invalid type for ❰List❱ elements" + + long = + "Explanation: ❰List❱s can optionally document the type of their elements with a \n\ + \type annotation, like this: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────┐ \n\ + \ │ [1, 2, 3] : List Integer │ A ❰List❱ of three ❰Integer❱s \n\ + \ └──────────────────────────┘ \n\ + \ ⇧ \n\ + \ The type of the ❰List❱'s elements, which are ❰Integer❱s \n\ + \ \n\ + \ \n\ + \ ┌───────────────────┐ \n\ + \ │ [] : List Integer │ An empty ❰List❱ \n\ + \ └───────────────────┘ \n\ + \ ⇧ \n\ + \ You must specify the type when the ❰List❱ is empty \n\ + \ \n\ + \ \n\ + \The element type must be a type and not something else. For example, the \n\ + \following element types are " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌──────────────┐ \n\ + \ │ ... : List 1 │ \n\ + \ └──────────────┘ \n\ + \ ⇧ \n\ + \ This is an ❰Integer❱ and not a ❰Type❱ \n\ + \ \n\ + \ \n\ + \ ┌─────────────────┐ \n\ + \ │ ... : List Type │ \n\ + \ └─────────────────┘ \n\ + \ ⇧ \n\ + \ This is a ❰Kind❱ and not a ❰Type❱ \n\ + \ \n\ + \ \n\ + \You declared that the ❰List❱'s elements should have type: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... which is not a ❰Type❱ \n" + where + txt0 = build expr0 + +prettyTypeMessage MissingListType = do + ErrorMessages {..} + where + short = "An empty list requires a type annotation" + + long = + "Explanation: Lists do not require a type annotation if they have at least one \n\ + \element: \n\ + \ \n\ + \ \n\ + \ ┌───────────┐ \n\ + \ │ [1, 2, 3] │ The compiler can infer that this list has type ❰List Integer❱\n\ + \ └───────────┘ \n\ + \ \n\ + \ \n\ + \However, empty lists still require a type annotation: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────┐ \n\ + \ │ [] : List Integer │ This type annotation is mandatory \n\ + \ └───────────────────┘ \n\ + \ \n\ + \ \n\ + \You cannot supply an empty list without a type annotation \n" + +prettyTypeMessage (MismatchedListElements i expr0 expr1 expr2) = + ErrorMessages {..} + where + short = "List elements should have the same type" + + long = + "Explanation: Every element in a list must have the same type \n\ + \ \n\ + \For example, this is a valid ❰List❱: \n\ + \ \n\ + \ \n\ + \ ┌───────────┐ \n\ + \ │ [1, 2, 3] │ Every element in this ❰List❱ is an ❰Integer❱ \n\ + \ └───────────┘ \n\ + \ \n\ + \ \n\ + \.. but this is " <> _NOT <> " a valid ❰List❱: \n\ + \ \n\ + \ \n\ + \ ┌───────────────┐ \n\ + \ │ [1, \"ABC\", 3] │ The first and second element have different types \n\ + \ └───────────────┘ \n\ + \ \n\ + \ \n\ + \Your first ❰List❱ elements has this type: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... but the following element at index " <> txt1 <> ": \n\ + \ \n\ + \↳ " <> txt2 <> " \n\ + \ \n\ + \... has this type instead: \n\ + \ \n\ + \↳ " <> txt3 <> " \n" + where + txt0 = build expr0 + txt1 = build i + txt2 = build expr1 + txt3 = build expr2 + +prettyTypeMessage (InvalidListElement i expr0 expr1 expr2) = + ErrorMessages {..} + where + short = "List element has the wrong type" + + long = + "Explanation: Every element in the list must have a type matching the type \n\ + \annotation at the end of the list \n\ + \ \n\ + \For example, this is a valid ❰List❱: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────┐ \n\ + \ │ [1, 2, 3] : List Integer │ Every element in this ❰List❱ is an ❰Integer❱ \n\ + \ └──────────────────────────┘ \n\ + \ \n\ + \ \n\ + \.. but this is " <> _NOT <> " a valid ❰List❱: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────────┐ \n\ + \ │ [1, \"ABC\", 3] : List Integer │ The second element is not an ❰Integer❱ \n\ + \ └──────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \Your ❰List❱ elements should have this type: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... but the following element at index " <> txt1 <> ": \n\ + \ \n\ + \↳ " <> txt2 <> " \n\ + \ \n\ + \... has this type instead: \n\ + \ \n\ + \↳ " <> txt3 <> " \n" + where + txt0 = build expr0 + txt1 = build i + txt2 = build expr1 + txt3 = build expr2 + +prettyTypeMessage (InvalidOptionalType expr0) = ErrorMessages {..} + where + short = "Invalid type for ❰Optional❱ element" + + long = + "Explanation: Every optional element ends with a type annotation for the element \n\ + \that might be present, like this: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────┐ \n\ + \ │ [1] : Optional Integer │ An optional element that's present \n\ + \ └────────────────────────┘ \n\ + \ ⇧ \n\ + \ The type of the ❰Optional❱ element, which is an ❰Integer❱ \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────┐ \n\ + \ │ [] : Optional Integer │ An optional element that's absent \n\ + \ └────────────────────────┘ \n\ + \ ⇧ \n\ + \ You still specify the type even when the element is absent \n\ + \ \n\ + \ \n\ + \The element type must be a type and not something else. For example, the \n\ + \following element types are " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────┐ \n\ + \ │ ... : Optional 1 │ \n\ + \ └──────────────────┘ \n\ + \ ⇧ \n\ + \ This is an ❰Integer❱ and not a ❰Type❱ \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────┐ \n\ + \ │ ... : Optional Type │ \n\ + \ └─────────────────────┘ \n\ + \ ⇧ \n\ + \ This is a ❰Kind❱ and not a ❰Type❱ \n\ + \ \n\ + \ \n\ + \Even if the element is absent you still must specify a valid type \n\ + \ \n\ + \You declared that the ❰Optional❱ element should have type: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... which is not a ❰Type❱ \n" + where + txt0 = build expr0 + +prettyTypeMessage (InvalidOptionalElement expr0 expr1 expr2) = ErrorMessages {..} + where + short = "❰Optional❱ element has the wrong type" + + long = + "Explanation: An ❰Optional❱ element must have a type matching the type annotation\n\ + \ \n\ + \For example, this is a valid ❰Optional❱ value: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────┐ \n\ + \ │ [1] : Optional Integer │ ❰1❱ is an ❰Integer❱, which matches the type \n\ + \ └────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... but this is " <> _NOT <> " a valid ❰Optional❱ value: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────────┐ \n\ + \ │ [\"ABC\"] : Optional Integer │ ❰\"ABC\"❱ is not an ❰Integer❱ \n\ + \ └────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \Your ❰Optional❱ element should have this type: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... but the element you provided: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... has this type instead: \n\ + \ \n\ + \↳ " <> txt2 <> " \n" + where + txt0 = build expr0 + txt1 = build expr1 + txt2 = build expr2 + +prettyTypeMessage (InvalidOptionalLiteral n) = ErrorMessages {..} + where + short = "Multiple ❰Optional❱ elements not allowed" + + long = + "Explanation: The syntax for ❰Optional❱ values resembles the syntax for ❰List❱s: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────┐ \n\ + \ │ [] : Optional Integer │ An ❰Optional❱ value which is absent \n\ + \ └───────────────────────┘ \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────┐ \n\ + \ │ [] : List Integer │ An empty (0-element) ❰List❱ \n\ + \ └───────────────────────┘ \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────┐ \n\ + \ │ [1] : Optional Integer │ An ❰Optional❱ value which is present \n\ + \ └────────────────────────┘ \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────┐ \n\ + \ │ [1] : List Integer │ A singleton (1-element) ❰List❱ \n\ + \ └────────────────────────┘ \n\ + \ \n\ + \ \n\ + \However, an ❰Optional❱ value can " <> _NOT <> " have more than one element, whereas a\n\ + \❰List❱ can have multiple elements: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────┐ \n\ + \ │ [1, 2] : Optional Integer │ Invalid: multiple elements " <> _NOT <> " allowed\n\ + \ └───────────────────────────┘ \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────┐ \n\ + \ │ [1, 2] : List Integer │ Valid: multiple elements allowed \n\ + \ └───────────────────────────┘ \n\ + \ \n\ + \ \n\ + \Some common reasons why you might get this error: \n\ + \ \n\ + \● You accidentally typed ❰Optional❱ when you meant ❰List❱, like this: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────────────────────────────────┐ \n\ + \ │ List/length Integer ([1, 2, 3] : Optional Integer) │ \n\ + \ └────────────────────────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ This should be ❰List❱ instead \n\ + \ \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \Your ❰Optional❱ value had this many elements: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... when an ❰Optional❱ value can only have at most one element \n" + where + txt0 = build n + +prettyTypeMessage (InvalidFieldType k expr0) = ErrorMessages {..} + where + short = "Invalid field type" + + long = + "Explanation: Every record type documents the type of each field, like this: \n\ + \ \n\ + \ ┌──────────────────────────────────────────────┐ \n\ + \ │ { foo : Integer, bar : Integer, baz : Text } │ \n\ + \ └──────────────────────────────────────────────┘ \n\ + \ \n\ + \However, fields cannot be annotated with expressions other than types \n\ + \ \n\ + \For example, these record types are " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────────┐ \n\ + \ │ { foo : Integer, bar : 1 } │ \n\ + \ └────────────────────────────┘ \n\ + \ ⇧ \n\ + \ ❰1❱ is an ❰Integer❱ and not a ❰Type❱ \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────┐ \n\ + \ │ { foo : Integer, bar : Type } │ \n\ + \ └───────────────────────────────┘ \n\ + \ ⇧ \n\ + \ ❰Type❱ is a ❰Kind❱ and not a ❰Type❱ \n\ + \ \n\ + \ \n\ + \You provided a record type with a key named: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... annotated with the following expression: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... which is not a type \n" + where + txt0 = build k + txt1 = build expr0 + +prettyTypeMessage (InvalidField k expr0) = ErrorMessages {..} + where + short = "Invalid field" + + long = + "Explanation: Every record literal is a set of fields assigned to values, like \n\ + \this: \n\ + \ \n\ + \ ┌────────────────────────────────────────┐ \n\ + \ │ { foo = 100, bar = True, baz = \"ABC\" } │ \n\ + \ └────────────────────────────────────────┘ \n\ + \ \n\ + \However, fields can only be terms and cannot be types or kinds \n\ + \ \n\ + \For example, these record literals are " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────┐ \n\ + \ │ { foo = 100, bar = Text } │ \n\ + \ └───────────────────────────┘ \n\ + \ ⇧ \n\ + \ ❰Text❱ is a type and not a term \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────┐ \n\ + \ │ { foo = 100, bar = Type } │ \n\ + \ └───────────────────────────┘ \n\ + \ ⇧ \n\ + \ ❰Type❱ is a kind and not a term \n\ + \ \n\ + \ \n\ + \You provided a record literal with a key named: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... whose value is: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... which is not a term \n" + where + txt0 = build k + txt1 = build expr0 + +prettyTypeMessage (InvalidAlternativeType k expr0) = ErrorMessages {..} + where + short = "Invalid alternative" + + long = + "Explanation: Every union literal begins by selecting one alternative and \n\ + \specifying the value for that alternative, like this: \n\ + \ \n\ + \ \n\ + \ Select the ❰Left❱ alternative, whose value is ❰True❱ \n\ + \ ⇩ \n\ + \ ┌──────────────────────────────────┐ \n\ + \ │ < Left = True, Right : Natural > │ A union literal with two alternatives \n\ + \ └──────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \However, this value must be a term and not a type. For example, the following \n\ + \values are " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────────────┐ \n\ + \ │ < Left = Text, Right : Natural > │ Invalid union literal \n\ + \ └──────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ This is a type and not a term \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────┐ \n\ + \ │ < Left = Type, Right : Type > │ Invalid union type \n\ + \ └───────────────────────────────┘ \n\ + \ ⇧ \n\ + \ This is a kind and not a term \n\ + \ \n\ + \ \n\ + \Some common reasons why you might get this error: \n\ + \ \n\ + \● You accidentally typed ❰=❱ instead of ❰:❱ for a union literal with one \n\ + \ alternative: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────┐ \n\ + \ │ < Example = Text > │ \n\ + \ └────────────────────┘ \n\ + \ ⇧ \n\ + \ This could be ❰:❱ instead \n\ + \ \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \You provided a union literal with an alternative named: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... whose value is: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... which is not a term \n" + where + txt0 = build k + txt1 = build expr0 + +prettyTypeMessage (InvalidAlternative k expr0) = ErrorMessages {..} + where + short = "Invalid alternative" + + long = + "Explanation: Every union type specifies the type of each alternative, like this:\n\ + \ \n\ + \ \n\ + \ The type of the first alternative is ❰Bool❱ \n\ + \ ⇩ \n\ + \ ┌──────────────────────────────────┐ \n\ + \ │ < Left : Bool, Right : Natural > │ A union type with two alternatives \n\ + \ └──────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ The type of the second alternative is ❰Natural❱ \n\ + \ \n\ + \ \n\ + \However, these alternatives can only be annotated with types. For example, the \n\ + \following union types are " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────────┐ \n\ + \ │ < Left : Bool, Right : 1 > │ Invalid union type \n\ + \ └────────────────────────────┘ \n\ + \ ⇧ \n\ + \ This is a term and not a type \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────┐ \n\ + \ │ < Left : Bool, Right : Type > │ Invalid union type \n\ + \ └───────────────────────────────┘ \n\ + \ ⇧ \n\ + \ This is a kind and not a type \n\ + \ \n\ + \ \n\ + \Some common reasons why you might get this error: \n\ + \ \n\ + \● You accidentally typed ❰:❱ instead of ❰=❱ for a union literal with one \n\ + \ alternative: \n\ + \ \n\ + \ ┌─────────────────┐ \n\ + \ │ < Example : 1 > │ \n\ + \ └─────────────────┘ \n\ + \ ⇧ \n\ + \ This could be ❰=❱ instead \n\ + \ \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \You provided a union type with an alternative named: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... annotated with the following expression which is not a type: \n\ + \ \n\ + \↳ " <> txt1 <> " \n" + where + txt0 = build k + txt1 = build expr0 + +prettyTypeMessage (ListAppendMismatch expr0 expr1) = ErrorMessages {..} + where + short = "You can only append ❰List❱s with matching element types" + + long = + "Explanation: You can append two ❰List❱s using the ❰#❱ operator, like this: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────┐ \n\ + \ │ [1, 2, 3] # [4, 5] │ \n\ + \ └────────────────────┘ \n\ + \ \n\ + \ \n\ + \... but you cannot append two ❰List❱s if they have different element types. \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ These elements have type ❰Integer❱ \n\ + \ ⇩ \n\ + \ ┌───────────────────────────┐ \n\ + \ │ [1, 2, 3] # [True, False] │ Invalid: the element types don't match \n\ + \ └───────────────────────────┘ \n\ + \ ⇧ \n\ + \ These elements have type ❰Bool❱ \n\ + \ \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \You tried to append a ❰List❱ thas has elements of type: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... with another ❰List❱ that has elements of type: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... and those two types do not match \n" + where + txt0 = build expr0 + txt1 = build expr1 + +prettyTypeMessage (DuplicateAlternative k) = ErrorMessages {..} + where + short = "Duplicate union alternative" + + long = + "Explanation: Unions may not have two alternatives that share the same name \n\ + \ \n\ + \For example, the following expressions are " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────┐ \n\ + \ │ < foo = True | foo : Text > │ Invalid: ❰foo❱ appears twice \n\ + \ └─────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────────────┐ \n\ + \ │ < foo = 1 | bar : Bool | bar : Text > │ Invalid: ❰bar❱ appears twice \n\ + \ └───────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \You have more than one alternative named: \n\ + \ \n\ + \↳ " <> txt0 <> " \n" + where + txt0 = build k + +prettyTypeMessage (MustCombineARecord c expr0 expr1) = ErrorMessages {..} + where + short = "You can only combine records" + + long = + "Explanation: You can combine records using the ❰" <> op <> "❱ operator, like this:\n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────────────────┐ \n\ + \ │ { foo = 1, bar = \"ABC\" } " <> op <> " { baz = True } │ \n\ + \ └───────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────────┐ \n\ + \ │ λ(r : { foo : Bool }) → r " <> op <> " { bar = \"ABC\" } │ \n\ + \ └─────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... but you cannot combine values that are not records. \n\ + \ \n\ + \For example, the following expressions are " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────────┐ \n\ + \ │ { foo = 1, bar = \"ABC\" } " <> op <> " 1 │ \n\ + \ └──────────────────────────────┘ \n\ + \ ⇧ \n\ + \ Invalid: Not a record \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────────────────┐ \n\ + \ │ { foo = 1, bar = \"ABC\" } " <> op <> " { baz : Bool } │ \n\ + \ └───────────────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ Invalid: This is a record type and not a record\n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────────────────┐ \n\ + \ │ { foo = 1, bar = \"ABC\" } " <> op <> " < baz = True > │ \n\ + \ └───────────────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ Invalid: This is a union and not a record \n\ + \ \n\ + \ \n\ + \You tried to combine the following value: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... which is not a record, but is actually a: \n\ + \ \n\ + \↳ " <> txt1 <> " \n" + where + op = build c + txt0 = build expr0 + txt1 = build expr1 + +prettyTypeMessage (FieldCollision k) = ErrorMessages {..} + where + short = "Field collision" + + long = + "Explanation: You can combine records if they don't share any fields in common, \n\ + \like this: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────────────────┐ \n\ + \ │ { foo = 1, bar = \"ABC\" } ∧ { baz = True } │ \n\ + \ └───────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────────────────────┐ \n\ + \ │ λ(r : { baz : Bool}) → { foo = 1 } ∧ r │ \n\ + \ └────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... but you cannot merge two records that share the same field \n\ + \ \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────────────────┐ \n\ + \ │ { foo = 1, bar = \"ABC\" } ∧ { foo = True } │ Invalid: Colliding ❰foo❱ fields\n\ + \ └───────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \Some common reasons why you might get this error: \n\ + \ \n\ + \● You tried to use ❰∧❱ to update a field's value, like this: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────────────────────┐ \n\ + \ │ { foo = 1, bar = \"ABC\" } ∧ { foo = 2 } │ \n\ + \ └────────────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ Invalid attempt to update ❰foo❱'s value to ❰2❱\n\ + \ \n\ + \ Field updates are intentionally not allowed as the Dhall language discourages \n\ + \ patch-oriented programming \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \You combined two records that share the following field: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... which is not allowed \n" + where + txt0 = build k + +prettyTypeMessage (MustMergeARecord expr0 expr1) = ErrorMessages {..} + where + short = "❰merge❱ expects a record of handlers" + + long = + "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ + \handler per alternative, like this: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────────────────────────────────┐ \n\ + \ │ let union = < Left = +2 | Right : Bool > │ \n\ + \ │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ + \ │ in merge handlers union : Bool │ \n\ + \ └─────────────────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... but the first argument to ❰merge❱ must be a record and not some other type. \n\ + \ \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────┐ \n\ + \ │ let handler = λ(x : Bool) → x │ \n\ + \ │ in merge handler < Foo = True > : True │ \n\ + \ └─────────────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ Invalid: ❰handler❱ isn't a record \n\ + \ \n\ + \ \n\ + \Some common reasons why you might get this error: \n\ + \ \n\ + \● You accidentally provide an empty record type instead of an empty record when \n\ + \ you ❰merge❱ an empty union: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────────────────────┐ \n\ + \ │ λ(x : <>) → λ(a : Type) → merge {} x : a │ \n\ + \ └──────────────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ This should be ❰{=}❱ instead \n\ + \ \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \You provided the following handler: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... which is not a record, but is actually a value of type: \n\ + \ \n\ + \↳ " <> txt1 <> " \n" + where + txt0 = build expr0 + txt1 = build expr1 + +prettyTypeMessage (MustMergeUnion expr0 expr1) = ErrorMessages {..} + where + short = "❰merge❱ expects a union" + + long = + "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ + \handler per alternative, like this: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────────────────────────────────┐ \n\ + \ │ let union = < Left = +2 | Right : Bool > │ \n\ + \ │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ + \ │ in merge handlers union : Bool │ \n\ + \ └─────────────────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... but the second argument to ❰merge❱ must be a union and not some other type. \n\ + \ \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────────────────────┐ \n\ + \ │ let handlers = { Foo = λ(x : Bool) → x } │ \n\ + \ │ in merge handlers True : True │ \n\ + \ └──────────────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ Invalid: ❰True❱ isn't a union \n\ + \ \n\ + \ \n\ + \You tried to ❰merge❱ this expression: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... which is not a union, but is actually a value of type: \n\ + \ \n\ + \↳ " <> txt1 <> " \n" + where + txt0 = build expr0 + txt1 = build expr1 + +prettyTypeMessage (UnusedHandler ks) = ErrorMessages {..} + where + short = "Unused handler" + + long = + "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ + \handler per alternative, like this: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────────────────────────────────┐ \n\ + \ │ let union = < Left = +2 | Right : Bool > │ \n\ + \ │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ + \ │ in merge handlers union : Bool │ \n\ + \ └─────────────────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... but you must provide exactly one handler per alternative in the union. You \n\ + \cannot supply extra handlers \n\ + \ \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────────────┐ \n\ + \ │ let union = < Left = +2 > │ The ❰Right❱ alternative is missing\n\ + \ │ in let handlers = │ \n\ + \ │ { Left = Natural/even │ \n\ + \ │ , Right = λ(x : Bool) → x │ Invalid: ❰Right❱ handler isn't used\n\ + \ │ } │ \n\ + \ │ in merge handlers union : Bool │ \n\ + \ └───────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \You provided the following handlers: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... which had no matching alternatives in the union you tried to ❰merge❱ \n" + where + txt0 = build (Text.intercalate ", " (Data.Set.toList ks)) + +prettyTypeMessage (MissingHandler ks) = ErrorMessages {..} + where + short = "Missing handler" + + long = + "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ + \handler per alternative, like this: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────────────────────────────────┐ \n\ + \ │ let union = < Left = +2 | Right : Bool > │ \n\ + \ │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ + \ │ in merge handlers union : Bool │ \n\ + \ └─────────────────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... but you must provide exactly one handler per alternative in the union. You \n\ + \cannot omit any handlers \n\ + \ \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ Invalid: Missing ❰Right❱ handler \n\ + \ ⇩ \n\ + \ ┌─────────────────────────────────────────────────┐ \n\ + \ │ let handlers = { Left = Natural/even } │ \n\ + \ │ in let union = < Left = +2 | Right : Bool > │ \n\ + \ │ in merge handlers union : Bool │ \n\ + \ └─────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \Note that you need to provide handlers for other alternatives even if those \n\ + \alternatives are never used \n\ + \ \n\ + \You need to supply the following handlers: \n\ + \ \n\ + \↳ " <> txt0 <> " \n" + where + txt0 = build (Text.intercalate ", " (Data.Set.toList ks)) + +prettyTypeMessage MissingMergeType = + ErrorMessages {..} + where + short = "An empty ❰merge❱ requires a type annotation" + + long = + "Explanation: A ❰merge❱ does not require a type annotation if the union has at \n\ + \least one alternative, like this \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────────────────────────────────┐ \n\ + \ │ let union = < Left = +2 | Right : Bool > │ \n\ + \ │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ + \ │ in merge handlers union │ \n\ + \ └─────────────────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \However, you must provide a type annotation when merging an empty union: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────────────┐ \n\ + \ │ λ(a : <>) → merge {=} a : Bool │ \n\ + \ └────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ This can be any type \n\ + \ \n\ + \ \n\ + \You can provide any type at all as the annotation, since merging an empty \n\ + \union can produce any type of output \n" + +prettyTypeMessage (HandlerInputTypeMismatch expr0 expr1 expr2) = + ErrorMessages {..} + where + short = "Wrong handler input type" + + long = + "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ + \handler per alternative, like this: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────────────────────────────────┐ \n\ + \ │ let union = < Left = +2 | Right : Bool > │ \n\ + \ │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ + \ │ in merge handlers union : Bool │ \n\ + \ └─────────────────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... as long as the input type of each handler function matches the type of the \n\ + \corresponding alternative: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────────────────────────────────┐ \n\ + \ │ union : < Left : Natural | Right : Bool > │ \n\ + \ └───────────────────────────────────────────────────────────┘ \n\ + \ ⇧ ⇧ \n\ + \ These must match These must match \n\ + \ ⇩ ⇩ \n\ + \ ┌───────────────────────────────────────────────────────────┐ \n\ + \ │ handlers : { Left : Natural → Bool, Right : Bool → Bool } │ \n\ + \ └───────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ Invalid: Doesn't match the type of the ❰Right❱ alternative \n\ + \ ⇩ \n\ + \ ┌──────────────────────────────────────────────────────────────────────┐ \n\ + \ │ let handlers = { Left = Natural/even | Right = λ(x : Text) → x } │ \n\ + \ │ in let union = < Left = +2 | Right : Bool > │ \n\ + \ │ in merge handlers union : Bool │ \n\ + \ └──────────────────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \Your handler for the following alternative: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... needs to accept an input value of type: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... but actually accepts an input value of a different type: \n\ + \ \n\ + \↳ " <> txt2 <> " \n" + where + txt0 = build expr0 + txt1 = build expr1 + txt2 = build expr2 + +prettyTypeMessage (InvalidHandlerOutputType expr0 expr1 expr2) = + ErrorMessages {..} + where + short = "Wrong handler output type" + + long = + "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ + \handler per alternative, like this: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────────────────────────────────┐ \n\ + \ │ let union = < Left = +2 | Right : Bool > │ \n\ + \ │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ + \ │ in merge handlers union : Bool │ \n\ + \ └─────────────────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... as long as the output type of each handler function matches the declared type\n\ + \of the result: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────────────────────────────────┐ \n\ + \ │ handlers : { Left : Natural → Bool, Right : Bool → Bool } │ \n\ + \ └───────────────────────────────────────────────────────────┘ \n\ + \ ⇧ ⇧ \n\ + \ These output types ... \n\ + \ \n\ + \ ... must match the declared type of the ❰merge❱ \n\ + \ ⇩ \n\ + \ ┌─────────────────────────────┐ \n\ + \ │ merge handlers union : Bool │ \n\ + \ └─────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────────────────────────────────────────────────┐ \n\ + \ │ let union = < Left = +2 | Right : Bool > │ \n\ + \ │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ + \ │ in merge handlers union : Text │ \n\ + \ └──────────────────────────────────────────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ Invalid: Doesn't match output of either handler\n\ + \ \n\ + \ \n\ + \Your handler for the following alternative: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... needs to return an output value of type: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... but actually returns an output value of a different type: \n\ + \ \n\ + \↳ " <> txt2 <> " \n" + where + txt0 = build expr0 + txt1 = build expr1 + txt2 = build expr2 + +prettyTypeMessage (HandlerOutputTypeMismatch key0 expr0 key1 expr1) = + ErrorMessages {..} + where + short = "Handlers should have the same output type" + + long = + "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ + \handler per alternative, like this: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────────────────────────────────┐ \n\ + \ │ let union = < Left = +2 | Right : Bool > │ \n\ + \ │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ + \ │ in merge handlers union │ \n\ + \ └─────────────────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... as long as the output type of each handler function is the same: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────────────────────────────────┐ \n\ + \ │ handlers : { Left : Natural → Bool, Right : Bool → Bool } │ \n\ + \ └───────────────────────────────────────────────────────────┘ \n\ + \ ⇧ ⇧ \n\ + \ These output types both match \n\ + \ \n\ + \ \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────────────┐ \n\ + \ │ let union = < Left = +2 | Right : Bool > │ \n\ + \ │ in let handlers = │ \n\ + \ │ { Left = λ(x : Natural) → x │ This outputs ❰Natural❱ \n\ + \ │ , Right = λ(x : Bool ) → x │ This outputs ❰Bool❱ \n\ + \ │ } │ \n\ + \ │ in merge handlers union │ \n\ + \ └─────────────────────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ Invalid: The handlers in this record don't have matching outputs\n\ + \ \n\ + \ \n\ + \The handler for the ❰" <> txt0 <> "❱ alternative has this output type: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... but the handler for the ❰" <> txt2 <> "❱ alternative has this output type instead:\n\ + \ \n\ + \↳ " <> txt3 <> " \n" + where + txt0 = build key0 + txt1 = build expr0 + txt2 = build key1 + txt3 = build expr1 + +prettyTypeMessage (HandlerNotAFunction k expr0) = ErrorMessages {..} + where + short = "Handler is not a function" + + long = + "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ + \handler per alternative, like this: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────────────────────────────────┐ \n\ + \ │ let union = < Left = +2 | Right : Bool > │ \n\ + \ │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ + \ │ in merge handlers union : Bool │ \n\ + \ └─────────────────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... as long as each handler is a function \n\ + \ \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────┐ \n\ + \ │ merge { Foo = True } < Foo = 1 > : Bool │ \n\ + \ └─────────────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ Invalid: Not a function \n\ + \ \n\ + \ \n\ + \Your handler for this alternative: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... has the following type: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... which is not the type of a function \n" + where + txt0 = build k + txt1 = build expr0 + +prettyTypeMessage (NotARecord k expr0 expr1) = ErrorMessages {..} + where + short = "Not a record" + + long = + "Explanation: You can only access fields on records, like this: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────┐ \n\ + \ │ { foo = True, bar = \"ABC\" }.foo │ This is valid ... \n\ + \ └─────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────────────────┐ \n\ + \ │ λ(r : { foo : Bool, bar : Text }) → r.foo │ ... and so is this \n\ + \ └───────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... but you cannot access fields on non-record expressions \n\ + \ \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌───────┐ \n\ + \ │ 1.foo │ \n\ + \ └───────┘ \n\ + \ ⇧ \n\ + \ Invalid: Not a record \n\ + \ \n\ + \ \n\ + \Some common reasons why you might get this error: \n\ + \ \n\ + \● You accidentally try to access a field of a union instead of a record, like \n\ + \ this: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────┐ \n\ + \ │ < foo : a >.foo │ \n\ + \ └─────────────────┘ \n\ + \ ⇧ \n\ + \ This is a union, not a record \n\ + \ \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \You tried to access a field named: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... on the following expression which is not a record: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... but is actually an expression of type: \n\ + \ \n\ + \↳ " <> txt2 <> " \n" + where + txt0 = build k + txt1 = build expr0 + txt2 = build expr1 + +prettyTypeMessage (MissingField k expr0) = ErrorMessages {..} + where + short = "Missing record field" + + long = + "Explanation: You can only access fields on records, like this: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────┐ \n\ + \ │ { foo = True, bar = \"ABC\" }.foo │ This is valid ... \n\ + \ └─────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────────────────┐ \n\ + \ │ λ(r : { foo : Bool, bar : Text }) → r.foo │ ... and so is this \n\ + \ └───────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... but you can only access fields if they are present \n\ + \ \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ ┌─────────────────────────────────┐ \n\ + \ │ { foo = True, bar = \"ABC\" }.qux │ \n\ + \ └─────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ Invalid: the record has no ❰qux❱ field \n\ + \ \n\ + \You tried to access a field named: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... but the field is missing because the record only defines the following fields:\n\ + \ \n\ + \↳ " <> txt1 <> " \n" + where + txt0 = build k + txt1 = build expr0 + +prettyTypeMessage (CantAnd expr0 expr1) = + buildBooleanOperator "&&" expr0 expr1 + +prettyTypeMessage (CantOr expr0 expr1) = + buildBooleanOperator "||" expr0 expr1 + +prettyTypeMessage (CantEQ expr0 expr1) = + buildBooleanOperator "==" expr0 expr1 + +prettyTypeMessage (CantNE expr0 expr1) = + buildBooleanOperator "/=" expr0 expr1 + +prettyTypeMessage (CantTextAppend expr0 expr1) = ErrorMessages {..} + where + short = "❰++❱ only works on ❰Text❱" + + long = + "Explanation: The ❰++❱ operator expects two arguments that have type ❰Text❱ \n\ + \ \n\ + \For example, this is a valid use of ❰++❱: \n\ + \ \n\ + \ \n\ + \ ┌────────────────┐ \n\ + \ │ \"ABC\" ++ \"DEF\" │ \n\ + \ └────────────────┘ \n\ + \ \n\ + \ \n\ + \Some common reasons why you might get this error: \n\ + \ \n\ + \● You might have thought that ❰++❱ was the operator to combine two lists: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────┐ \n\ + \ │ [1, 2, 3] ++ [4, 5, 6] │ Not valid \n\ + \ └────────────────────────┘ \n\ + \ \n\ + \ \n\ + \ ... but the list concatenation operator is actually ❰#❱: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────┐ \n\ + \ │ [1, 2, 3] # [4, 5, 6] │ Valid \n\ + \ └───────────────────────┘ \n\ + \ \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \You provided this argument: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... which does not have type ❰Text❱ but instead has type: \n\ + \ \n\ + \↳ " <> txt1 <> " \n" + where + txt0 = build expr0 + txt1 = build expr1 + +prettyTypeMessage (CantListAppend expr0 expr1) = ErrorMessages {..} + where + short = "❰#❱ only works on ❰List❱s" + + long = + "Explanation: The ❰#❱ operator expects two arguments that are both ❰List❱s \n\ + \ \n\ + \For example, this is a valid use of ❰#❱: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────┐ \n\ + \ │ [1, 2, 3] # [4, 5, 6] │ \n\ + \ └───────────────────────┘ \n\ + \ \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \You provided this argument: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... which is not a ❰List❱ but instead has type: \n\ + \ \n\ + \↳ " <> txt1 <> " \n" + where + txt0 = build expr0 + txt1 = build expr1 + +prettyTypeMessage (CantAdd expr0 expr1) = + buildNaturalOperator "+" expr0 expr1 + +prettyTypeMessage (CantMultiply expr0 expr1) = + buildNaturalOperator "*" expr0 expr1 + +prettyTypeMessage (NoDependentTypes expr0 expr1) = ErrorMessages {..} + where + short = "No dependent types" + + long = + "Explanation: The Dhall programming language does not allow functions from terms \n\ + \to types. These function types are also known as \"dependent function types\" \n\ + \because you have a type whose value \"depends\" on the value of a term. \n\ + \ \n\ + \For example, this is " <> _NOT <> " a legal function type: \n\ + \ \n\ + \ \n\ + \ ┌─────────────┐ \n\ + \ │ Bool → Type │ \n\ + \ └─────────────┘ \n\ + \ \n\ + \ \n\ + \Similarly, this is " <> _NOT <> " legal code: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────────────────────────────────┐ \n\ + \ │ λ(Vector : Natural → Type → Type) → Vector +0 Text │ \n\ + \ └────────────────────────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ Invalid dependent type \n\ + \ \n\ + \ \n\ + \Your function type is invalid because the input has type: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... and the output has kind: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... which makes this a forbidden dependent function type \n" + where + txt0 = build expr0 + txt1 = build expr1 + +prettyTypeMessage (NoDependentLet expr0 expr1) = ErrorMessages {..} + where + short = "No dependent ❰let❱" + + long = + "Explanation: The Dhall programming language does not allow ❰let❱ expressions \n\ + \from terms to types. These ❰let❱ expressions are also known as \"dependent ❰let❱\n\ + \expressions\" because you have a type whose value depends on the value of a term.\n\ + \ \n\ + \The Dhall language forbids these dependent ❰let❱ expressions in order to \n\ + \guarantee that ❰let❱ expressions of the form: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────┐ \n\ + \ │ let x : t = r in e │ \n\ + \ └────────────────────┘ \n\ + \ \n\ + \ \n\ + \... are always equivalent to: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────┐ \n\ + \ │ (λ(x : t) → e) r │ \n\ + \ └──────────────────┘ \n\ + \ \n\ + \ \n\ + \This means that both expressions should normalize to the same result and if one \n\ + \of the two fails to type check then the other should fail to type check, too. \n\ + \ \n\ + \For this reason, the following is " <> _NOT <> " legal code: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────┐ \n\ + \ │ let x = 2 in Text │ \n\ + \ └───────────────────┘ \n\ + \ \n\ + \ \n\ + \... because the above ❰let❱ expression is equivalent to: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────┐ \n\ + \ │ let x : Integer = 2 in Text │ \n\ + \ └─────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... which in turn must be equivalent to: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────┐ \n\ + \ │ (λ(x : Integer) → Text) 2 │ \n\ + \ └───────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... which in turn fails to type check because this sub-expression: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────┐ \n\ + \ │ λ(x : Integer) → Text │ \n\ + \ └───────────────────────┘ \n\ + \ \n\ + \ \n\ + \... has type: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────┐ \n\ + \ │ ∀(x : Integer) → Text │ \n\ + \ └───────────────────────┘ \n\ + \ \n\ + \ \n\ + \... which is a forbidden dependent function type (i.e. a function from a term to\n\ + \a type). Therefore the equivalent ❰let❱ expression is also forbidden. \n\ + \ \n\ + \Your ❰let❱ expression is invalid because the input has type: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... and the output has kind: \n\ + \ \n\ + \↳ " <> txt1 <> " \n\ + \ \n\ + \... which makes this a forbidden dependent ❰let❱ expression \n" + where + txt0 = build expr0 + txt1 = build expr1 + +buildBooleanOperator :: Text -> Expr s X -> Expr s X -> ErrorMessages +buildBooleanOperator operator expr0 expr1 = ErrorMessages {..} + where + short = "❰" <> txt2 <> "❱ only works on ❰Bool❱s" + + long = + "Explanation: The ❰" <> txt2 <> "❱ operator expects two arguments that have type ❰Bool❱\n\ + \ \n\ + \For example, this is a valid use of ❰" <> txt2 <> "❱: \n\ + \ \n\ + \ \n\ + \ ┌───────────────┐ \n\ + \ │ True " <> txt2 <> " False │ \n\ + \ └───────────────┘ \n\ + \ \n\ + \ \n\ + \You provided this argument: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... which does not have type ❰Bool❱ but instead has type: \n\ + \ \n\ + \↳ " <> txt1 <> " \n" + where + txt0 = build expr0 + txt1 = build expr1 + + txt2 = build operator + +buildNaturalOperator :: Text -> Expr s X -> Expr s X -> ErrorMessages +buildNaturalOperator operator expr0 expr1 = ErrorMessages {..} + where + short = "❰" <> txt2 <> "❱ only works on ❰Natural❱s" + + long = + "Explanation: The ❰" <> txt2 <> "❱ operator expects two arguments that have type ❰Natural❱\n\ + \ \n\ + \For example, this is a valid use of ❰" <> txt2 <> "❱: \n\ + \ \n\ + \ \n\ + \ ┌─────────┐ \n\ + \ │ +3 " <> txt2 <> " +5 │ \n\ + \ └─────────┘ \n\ + \ \n\ + \ \n\ + \Some common reasons why you might get this error: \n\ + \ \n\ + \● You might have tried to use an ❰Integer❱, which is " <> _NOT <> " allowed: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────┐ \n\ + \ │ λ(x : Integer) → λ(y : Integer) → x " <> txt2 <> " y │ Not valid \n\ + \ └─────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \ You can only use ❰Natural❱ numbers \n\ + \ \n\ + \ \n\ + \● You might have mistakenly used an ❰Integer❱ literal, which is " <> _NOT <> " allowed:\n\ + \ \n\ + \ \n\ + \ ┌───────┐ \n\ + \ │ 2 " <> txt2 <> " 2 │ Not valid \n\ + \ └───────┘ \n\ + \ \n\ + \ \n\ + \ You need to prefix each literal with a ❰+❱ to transform them into ❰Natural❱ \n\ + \ literals, like this: \n\ + \ \n\ + \ \n\ + \ ┌─────────┐ \n\ + \ │ +2 " <> txt2 <> " +2 │ Valid \n\ + \ └─────────┘ \n\ + \ \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \You provided this argument: \n\ + \ \n\ + \↳ " <> txt0 <> " \n\ + \ \n\ + \... which does not have type ❰Natural❱ but instead has type: \n\ + \ \n\ + \↳ " <> txt1 <> " \n" + where + txt0 = build expr0 + txt1 = build expr1 + + txt2 = build operator -- | A structured type error that includes context data TypeError s = TypeError diff --git a/tests/Examples.hs b/tests/Examples.hs --- a/tests/Examples.hs +++ b/tests/Examples.hs @@ -1,9 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} module Examples where -import qualified NeatInterpolation import qualified Test.Tasty import qualified Test.Tasty.HUnit import qualified Util @@ -273,1008 +271,778 @@ _Bool_and_0 :: TestTree _Bool_and_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/and ([True, False, True] : List Bool) -|] + e <- Util.code "./Prelude/Bool/and ([True, False, True] : List Bool)" Util.assertNormalizesTo e "False" ) _Bool_and_1 :: TestTree _Bool_and_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/and ([] : List Bool) -|] + e <- Util.code "./Prelude/Bool/and ([] : List Bool)" Util.assertNormalizesTo e "True" ) _Bool_build_0 :: TestTree _Bool_build_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/build (λ(bool : Type) → λ(true : bool) → λ(false : bool) → true) -|] + e <- Util.code + "./Prelude/Bool/build (λ(bool : Type) → λ(true : bool) → λ(false : bool) → true)" Util.assertNormalizesTo e "True" ) _Bool_build_1 :: TestTree _Bool_build_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/build (λ(bool : Type) → λ(true : bool) → λ(false : bool) → false) -|] + e <- Util.code + "./Prelude/Bool/build (λ(bool : Type) → λ(true : bool) → λ(false : bool) → false)" Util.assertNormalizesTo e "False" ) _Bool_even_0 :: TestTree _Bool_even_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/even ([False, True, False] : List Bool) -|] + e <- Util.code "./Prelude/Bool/even ([False, True, False] : List Bool)" Util.assertNormalizesTo e "True" ) _Bool_even_1 :: TestTree _Bool_even_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/even ([False, True] : List Bool) -|] + e <- Util.code "./Prelude/Bool/even ([False, True] : List Bool)" Util.assertNormalizesTo e "False" ) _Bool_even_2 :: TestTree _Bool_even_2 = Test.Tasty.HUnit.testCase "Example #2" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/even ([False] : List Bool) -|] + e <- Util.code "./Prelude/Bool/even ([False] : List Bool)" Util.assertNormalizesTo e "False" ) _Bool_even_3 :: TestTree _Bool_even_3 = Test.Tasty.HUnit.testCase "Example #3" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/even ([] : List Bool) -|] + e <- Util.code "./Prelude/Bool/even ([] : List Bool)" Util.assertNormalizesTo e "True" ) _Bool_fold_0 :: TestTree _Bool_fold_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/fold True Integer 0 1 -|] + e <- Util.code "./Prelude/Bool/fold True Integer 0 1" Util.assertNormalizesTo e "0" ) _Bool_fold_1 :: TestTree _Bool_fold_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/fold False Integer 0 1 -|] + e <- Util.code "./Prelude/Bool/fold False Integer 0 1" Util.assertNormalizesTo e "1" ) _Bool_not_0 :: TestTree _Bool_not_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/not True -|] + e <- Util.code "./Prelude/Bool/not True" Util.assertNormalizesTo e "False" ) _Bool_not_1 :: TestTree _Bool_not_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/not False -|] + e <- Util.code "./Prelude/Bool/not False" Util.assertNormalizesTo e "True" ) _Bool_odd_0 :: TestTree _Bool_odd_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/odd ([True, False, True] : List Bool) -|] + e <- Util.code "./Prelude/Bool/odd ([True, False, True] : List Bool)" Util.assertNormalizesTo e "False" ) _Bool_odd_1 :: TestTree _Bool_odd_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/odd ([True, False] : List Bool) -|] + e <- Util.code "./Prelude/Bool/odd ([True, False] : List Bool)" Util.assertNormalizesTo e "True" ) _Bool_odd_2 :: TestTree _Bool_odd_2 = Test.Tasty.HUnit.testCase "Example #2" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/odd ([True] : List Bool) -|] + e <- Util.code "./Prelude/Bool/odd ([True] : List Bool)" Util.assertNormalizesTo e "True" ) _Bool_odd_3 :: TestTree _Bool_odd_3 = Test.Tasty.HUnit.testCase "Example #3" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/odd ([] : List Bool) -|] + e <- Util.code "./Prelude/Bool/odd ([] : List Bool)" Util.assertNormalizesTo e "False" ) _Bool_or_0 :: TestTree _Bool_or_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/or ([True, False, True] : List Bool) -|] + e <- Util.code "./Prelude/Bool/or ([True, False, True] : List Bool)" Util.assertNormalizesTo e "True" ) _Bool_or_1 :: TestTree _Bool_or_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/or ([] : List Bool) -|] + e <- Util.code "./Prelude/Bool/or ([] : List Bool)" Util.assertNormalizesTo e "False" ) _Bool_show_0 :: TestTree _Bool_show_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/show True -|] + e <- Util.code "./Prelude/Bool/show True" Util.assertNormalizesTo e "\"True\"" ) _Bool_show_1 :: TestTree _Bool_show_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Bool/show False -|] + e <- Util.code "./Prelude/Bool/show False" Util.assertNormalizesTo e "\"False\"" ) _Double_show_0 :: TestTree _Double_show_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Double/show -3.1 -|] + e <- Util.code "./Prelude/Double/show -3.1" Util.assertNormalizesTo e "\"-3.1\"" ) _Double_show_1 :: TestTree _Double_show_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Double/show 0.4 -|] + e <- Util.code "./Prelude/Double/show 0.4" Util.assertNormalizesTo e "\"0.4\"" ) _Integer_show_0 :: TestTree _Integer_show_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Integer/show -3 -|] + e <- Util.code "./Prelude/Integer/show -3" Util.assertNormalizesTo e "\"-3\"" ) _Integer_show_1 :: TestTree _Integer_show_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Integer/show 0 -|] + e <- Util.code "./Prelude/Integer/show 0" Util.assertNormalizesTo e "\"0\"" ) _List_all_0 :: TestTree _List_all_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/all Natural Natural/even ([+2, +3, +5] : List Natural) -|] + e <- Util.code "./Prelude/List/all Natural Natural/even ([+2, +3, +5] : List Natural)" Util.assertNormalizesTo e "False" ) _List_all_1 :: TestTree _List_all_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/all Natural Natural/even ([] : List Natural) -|] + e <- Util.code "./Prelude/List/all Natural Natural/even ([] : List Natural)" Util.assertNormalizesTo e "True" ) _List_any_0 :: TestTree _List_any_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/any Natural Natural/even ([+2, +3, +5] : List Natural) -|] + e <- Util.code "./Prelude/List/any Natural Natural/even ([+2, +3, +5] : List Natural)" Util.assertNormalizesTo e "True" ) _List_any_1 :: TestTree _List_any_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/any Natural Natural/even ([] : List Natural) -|] + e <- Util.code "./Prelude/List/any Natural Natural/even ([] : List Natural)" Util.assertNormalizesTo e "False" ) _List_build_0 :: TestTree _List_build_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/build -Text -( λ(list : Type) -→ λ(cons : Text → list → list) -→ λ(nil : list) -→ cons "ABC" (cons "DEF" nil) -) -|] + e <- Util.code + "./Prelude/List/build \n\ + \Text \n\ + \( λ(list : Type) \n\ + \→ λ(cons : Text → list → list) \n\ + \→ λ(nil : list) \n\ + \→ cons \"ABC\" (cons \"DEF\" nil)\n\ + \) \n" Util.assertNormalizesTo e "[\"ABC\", \"DEF\"] : List Text" ) _List_build_1 :: TestTree _List_build_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/build -Text -( λ(list : Type) -→ λ(cons : Text → list → list) -→ λ(nil : list) -→ nil -) -|] + e <- Util.code + "./Prelude/List/build \n\ + \Text \n\ + \( λ(list : Type) \n\ + \→ λ(cons : Text → list → list)\n\ + \→ λ(nil : list) \n\ + \→ nil \n\ + \) \n" Util.assertNormalizesTo e "[] : List Text" ) _List_concat_0 :: TestTree _List_concat_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/concat Integer -( [ [0, 1, 2] : List Integer - , [3, 4] : List Integer - , [5, 6, 7, 8] : List Integer - ] : List (List Integer) -) -|] + e <- Util.code + "./Prelude/List/concat Integer \n\ + \( [ [0, 1, 2] : List Integer\n\ + \ , [3, 4] : List Integer\n\ + \ , [5, 6, 7, 8] : List Integer\n\ + \ ] : List (List Integer) \n\ + \) \n" Util.assertNormalizesTo e "[0, 1, 2, 3, 4, 5, 6, 7, 8] : List Integer" ) _List_concat_1 :: TestTree _List_concat_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/concat Integer -( [ [] : List Integer - , [] : List Integer - , [] : List Integer - ] : List (List Integer) -) -|] + e <- Util.code + "./Prelude/List/concat Integer\n\ + \( [ [] : List Integer \n\ + \ , [] : List Integer \n\ + \ , [] : List Integer \n\ + \ ] : List (List Integer)\n\ + \) \n" Util.assertNormalizesTo e "[] : List Integer" ) _List_filter_0 :: TestTree _List_filter_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/filter Natural Natural/even ([+2, +3, +5] : List Natural) -|] + e <- Util.code + "./Prelude/List/filter Natural Natural/even ([+2, +3, +5] : List Natural)" Util.assertNormalizesTo e "[+2] : List Natural" ) _List_filter_1 :: TestTree _List_filter_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/filter Natural Natural/odd ([+2, +3, +5] : List Natural) -|] + e <- Util.code "./Prelude/List/filter Natural Natural/odd ([+2, +3, +5] : List Natural)" Util.assertNormalizesTo e "[+3, +5] : List Natural" ) _List_fold_0 :: TestTree _List_fold_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| - ./Prelude/List/fold - Natural - ([+2, +3, +5] : List Natural) - Natural - (λ(x : Natural) → λ(y : Natural) → x + y) - +0 -|] + e <- Util.code + "./Prelude/List/fold \n\ + \Natural \n\ + \([+2, +3, +5] : List Natural) \n\ + \Natural \n\ + \(λ(x : Natural) → λ(y : Natural) → x + y)\n\ + \+0 \n" Util.assertNormalizesTo e "+10" ) _List_fold_1 :: TestTree _List_fold_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| - λ(nil : Natural) -→ ./Prelude/List/fold - Natural - ([+2, +3, +5] : List Natural) - Natural - (λ(x : Natural) → λ(y : Natural) → x + y) - nil -|] + e <- Util.code + " λ(nil : Natural) \n\ + \→ ./Prelude/List/fold \n\ + \ Natural \n\ + \ ([+2, +3, +5] : List Natural) \n\ + \ Natural \n\ + \ (λ(x : Natural) → λ(y : Natural) → x + y)\n\ + \ nil \n" Util.assertNormalizesTo e "λ(nil : Natural) → +2 + +3 + +5 + nil" ) _List_fold_2 :: TestTree _List_fold_2 = Test.Tasty.HUnit.testCase "Example #2" (do - e <- Util.code [NeatInterpolation.text| - λ(list : Type) -→ λ(cons : Natural → list → list) -→ λ(nil : list) -→ ./Prelude/List/fold Natural ([+2, +3, +5] : List Natural) list cons nil -|] + e <- Util.code + " λ(list : Type) \n\ + \→ λ(cons : Natural → list → list) \n\ + \→ λ(nil : list) \n\ + \→ ./Prelude/List/fold Natural ([+2, +3, +5] : List Natural) list cons nil\n" Util.assertNormalizesTo e "λ(list : Type) → λ(cons : Natural → list → list) → λ(nil : list) → cons +2 (cons +3 (cons +5 nil))" ) _List_generate_0 :: TestTree _List_generate_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/generate +5 Bool Natural/even -|] + e <- Util.code "./Prelude/List/generate +5 Bool Natural/even" Util.assertNormalizesTo e "[True, False, True, False, True] : List Bool" ) _List_generate_1 :: TestTree _List_generate_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/generate +0 Bool Natural/even -|] + e <- Util.code "./Prelude/List/generate +0 Bool Natural/even" Util.assertNormalizesTo e "[] : List Bool" ) _List_head_0 :: TestTree _List_head_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/head Integer ([0, 1, 2] : List Integer) -|] + e <- Util.code "./Prelude/List/head Integer ([0, 1, 2] : List Integer)" Util.assertNormalizesTo e "[0] : Optional Integer" ) _List_head_1 :: TestTree _List_head_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/head Integer ([] : List Integer) -|] + e <- Util.code "./Prelude/List/head Integer ([] : List Integer)" Util.assertNormalizesTo e "[] : Optional Integer" ) _List_indexed_0 :: TestTree _List_indexed_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/indexed Bool ([True, False, True] : List Bool) -|] + e <- Util.code "./Prelude/List/indexed Bool ([True, False, True] : List Bool)" Util.assertNormalizesTo e "[{ index = +0, value = True }, { index = +1, value = False }, { index = +2, value = True }] : List { index : Natural, value : Bool }" ) _List_indexed_1 :: TestTree _List_indexed_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/indexed Bool ([] : List Bool) -|] + e <- Util.code "./Prelude/List/indexed Bool ([] : List Bool)" Util.assertNormalizesTo e "[] : List { index : Natural, value : Bool }" ) _List_iterate_0 :: TestTree _List_iterate_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/iterate +10 Natural (λ(x : Natural) → x * +2) +1 -|] + e <- Util.code "./Prelude/List/iterate +10 Natural (λ(x : Natural) → x * +2) +1" Util.assertNormalizesTo e "[+1, +2, +4, +8, +16, +32, +64, +128, +256, +512] : List Natural" ) _List_iterate_1 :: TestTree _List_iterate_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/iterate +0 Natural (λ(x : Natural) → x * +2) +1 -|] + e <- Util.code "./Prelude/List/iterate +0 Natural (λ(x : Natural) → x * +2) +1" Util.assertNormalizesTo e "[] : List Natural" ) _List_last_0 :: TestTree _List_last_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/last Integer ([0, 1, 2] : List Integer) -|] + e <- Util.code "./Prelude/List/last Integer ([0, 1, 2] : List Integer)" Util.assertNormalizesTo e "[2] : Optional Integer" ) _List_last_1 :: TestTree _List_last_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/last Integer ([] : List Integer) -|] + e <- Util.code "./Prelude/List/last Integer ([] : List Integer)" Util.assertNormalizesTo e "[] : Optional Integer" ) _List_length_0 :: TestTree _List_length_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/length Integer ([0, 1, 2] : List Integer) -|] + e <- Util.code "./Prelude/List/length Integer ([0, 1, 2] : List Integer)" Util.assertNormalizesTo e "+3" ) _List_length_1 :: TestTree _List_length_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/length Integer ([] : List Integer) -|] + e <- Util.code "./Prelude/List/length Integer ([] : List Integer)" Util.assertNormalizesTo e "+0" ) _List_map_0 :: TestTree _List_map_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/map Natural Bool Natural/even ([+2, +3, +5] : List Natural) -|] + e <- Util.code + "./Prelude/List/map Natural Bool Natural/even ([+2, +3, +5] : List Natural)" Util.assertNormalizesTo e "[True, False, False] : List Bool" ) _List_map_1 :: TestTree _List_map_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/map Natural Bool Natural/even ([] : List Natural) -|] + e <- Util.code "./Prelude/List/map Natural Bool Natural/even ([] : List Natural)" Util.assertNormalizesTo e "[] : List Bool" ) _List_null_0 :: TestTree _List_null_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/null Integer ([0, 1, 2] : List Integer) -|] + e <- Util.code "./Prelude/List/null Integer ([0, 1, 2] : List Integer)" Util.assertNormalizesTo e "False" ) _List_null_1 :: TestTree _List_null_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/null Integer ([] : List Integer) -|] + e <- Util.code "./Prelude/List/null Integer ([] : List Integer)" Util.assertNormalizesTo e "True" ) _List_replicate_0 :: TestTree _List_replicate_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/replicate +9 Integer 1 -|] + e <- Util.code "./Prelude/List/replicate +9 Integer 1" Util.assertNormalizesTo e "[1, 1, 1, 1, 1, 1, 1, 1, 1] : List Integer" ) _List_replicate_1 :: TestTree _List_replicate_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/replicate +0 Integer 1 -|] + e <- Util.code "./Prelude/List/replicate +0 Integer 1" Util.assertNormalizesTo e "[] : List Integer" ) _List_reverse_0 :: TestTree _List_reverse_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/reverse Integer ([0, 1, 2] : List Integer) -|] + e <- Util.code "./Prelude/List/reverse Integer ([0, 1, 2] : List Integer)" Util.assertNormalizesTo e "[2, 1, 0] : List Integer" ) _List_reverse_1 :: TestTree _List_reverse_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/reverse Integer ([] : List Integer) -|] + e <- Util.code "./Prelude/List/reverse Integer ([] : List Integer)" Util.assertNormalizesTo e "[] : List Integer" ) _List_shifted_0 :: TestTree _List_shifted_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/shifted -Bool -( [ [ { index = +0, value = True } - , { index = +1, value = True } - , { index = +2, value = True } - ] : List { index : Natural, value : Bool } - , [ { index = +0, value = False } - , { index = +1, value = False } - ] : List { index : Natural, value : Bool } - , [ { index = +0, value = True } - , { index = +1, value = True } - , { index = +2, value = True } - , { index = +3, value = True } - ] : List { index : Natural, value : Bool } - ] : List (List { index : Natural, value : Bool }) -) -|] + e <- Util.code + "./Prelude/List/shifted \n\ + \Bool \n\ + \( [ [ { index = +0, value = True } \n\ + \ , { index = +1, value = True } \n\ + \ , { index = +2, value = True } \n\ + \ ] : List { index : Natural, value : Bool } \n\ + \ , [ { index = +0, value = False } \n\ + \ , { index = +1, value = False } \n\ + \ ] : List { index : Natural, value : Bool } \n\ + \ , [ { index = +0, value = True } \n\ + \ , { index = +1, value = True } \n\ + \ , { index = +2, value = True } \n\ + \ , { index = +3, value = True } \n\ + \ ] : List { index : Natural, value : Bool } \n\ + \ ] : List (List { index : Natural, value : Bool })\n\ + \) \n" Util.assertNormalizesTo e "[{ index = +0, value = True }, { index = +1, value = True }, { index = +2, value = True }, { index = +3, value = False }, { index = +4, value = False }, { index = +5, value = True }, { index = +6, value = True }, { index = +7, value = True }, { index = +8, value = True }] : List { index : Natural, value : Bool }" ) _List_shifted_1 :: TestTree _List_shifted_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/shifted Bool ([] : List (List { index : Natural, value : Bool })) -|] + e <- Util.code + "./Prelude/List/shifted Bool ([] : List (List { index : Natural, value : Bool }))" Util.assertNormalizesTo e "[] : List { index : Natural, value : Bool }" ) _List_unzip_0 :: TestTree _List_unzip_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/unzip -Text -Bool -( [ { _1 = "ABC", _2 = True } - , { _1 = "DEF", _2 = False } - , { _1 = "GHI", _2 = True } - ] : List { _1 : Text, _2 : Bool } -) -|] + e <- Util.code + "./Prelude/List/unzip \n\ + \Text \n\ + \Bool \n\ + \( [ { _1 = \"ABC\", _2 = True } \n\ + \ , { _1 = \"DEF\", _2 = False } \n\ + \ , { _1 = \"GHI\", _2 = True } \n\ + \ ] : List { _1 : Text, _2 : Bool }\n\ + \) \n" Util.assertNormalizesTo e "{ _1 = [\"ABC\", \"DEF\", \"GHI\"] : List Text, _2 = [True, False, True] : List Bool }" ) _List_unzip_1 :: TestTree _List_unzip_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/List/unzip Text Bool ([] : List { _1 : Text, _2 : Bool }) -|] + e <- Util.code "./Prelude/List/unzip Text Bool ([] : List { _1 : Text, _2 : Bool })" Util.assertNormalizesTo e "{ _1 = [] : List Text, _2 = [] : List Bool }" ) _Monoid_00 :: TestTree _Monoid_00 = Test.Tasty.HUnit.testCase "Example #0" - (Util.assertTypeChecks [NeatInterpolation.text| -./Prelude/Bool/and - : ./Prelude/Monoid Bool -|] ) + (Util.assertTypeChecks "./Prelude/Bool/and : ./Prelude/Monoid Bool") _Monoid_01 :: TestTree _Monoid_01 = Test.Tasty.HUnit.testCase "Example #1" - (Util.assertTypeChecks [NeatInterpolation.text| -./Prelude/Bool/or - : ./Prelude/Monoid Bool -|] ) + (Util.assertTypeChecks "./Prelude/Bool/or : ./Prelude/Monoid Bool") _Monoid_02 :: TestTree _Monoid_02 = Test.Tasty.HUnit.testCase "Example #2" - (Util.assertTypeChecks [NeatInterpolation.text| -./Prelude/Bool/even - : ./Prelude/Monoid Bool -|] ) + (Util.assertTypeChecks "./Prelude/Bool/even : ./Prelude/Monoid Bool") _Monoid_03 :: TestTree _Monoid_03 = Test.Tasty.HUnit.testCase "Example #3" - (Util.assertTypeChecks[NeatInterpolation.text| -./Prelude/Bool/odd - : ./Prelude/Monoid Bool -|] ) + (Util.assertTypeChecks "./Prelude/Bool/odd : ./Prelude/Monoid Bool") _Monoid_04 :: TestTree _Monoid_04 = Test.Tasty.HUnit.testCase "Example #4" - (Util.assertTypeChecks [NeatInterpolation.text| -./Prelude/List/concat - : ∀(a : Type) → ./Prelude/Monoid (List a) -|] ) + (Util.assertTypeChecks + "./Prelude/List/concat : ∀(a : Type) → ./Prelude/Monoid (List a)" ) _Monoid_05 :: TestTree _Monoid_05 = Test.Tasty.HUnit.testCase "Example #5" - (Util.assertTypeChecks [NeatInterpolation.text| -./Prelude/List/shifted - : ∀(a : Type) → ./Prelude/Monoid (List { index : Natural, value : a }) -|] ) + (Util.assertTypeChecks + "./Prelude/List/shifted \n\ + \ : ∀(a : Type) → ./Prelude/Monoid (List { index : Natural, value : a })\n" ) _Monoid_06 :: TestTree _Monoid_06 = Test.Tasty.HUnit.testCase "Example #6" - (Util.assertTypeChecks [NeatInterpolation.text| -./Prelude/Natural/sum - : ./Prelude/Monoid Natural -|] ) + (Util.assertTypeChecks "./Prelude/Natural/sum : ./Prelude/Monoid Natural") _Monoid_07 :: TestTree _Monoid_07 = Test.Tasty.HUnit.testCase "Example #7" - (Util.assertTypeChecks [NeatInterpolation.text| -./Prelude/Natural/product - : ./Prelude/Monoid Natural -|] ) + (Util.assertTypeChecks "./Prelude/Natural/product : ./Prelude/Monoid Natural") _Monoid_08 :: TestTree _Monoid_08 = Test.Tasty.HUnit.testCase "Example #8" - (Util.assertTypeChecks [NeatInterpolation.text| -./Prelude/Optional/head - : ∀(a : Type) → ./Prelude/Monoid (Optional a) -|] ) + (Util.assertTypeChecks + "./Prelude/Optional/head : ∀(a : Type) → ./Prelude/Monoid (Optional a)" ) _Monoid_09 :: TestTree _Monoid_09 = Test.Tasty.HUnit.testCase "Example #9" - (Util.assertTypeChecks [NeatInterpolation.text| -./Prelude/Optional/last - : ∀(a : Type) → ./Prelude/Monoid (Optional a) -|] ) + (Util.assertTypeChecks + "./Prelude/Optional/last : ∀(a : Type) → ./Prelude/Monoid (Optional a)" ) _Monoid_10 :: TestTree _Monoid_10 = Test.Tasty.HUnit.testCase "Example #10" - (Util.assertTypeChecks [NeatInterpolation.text| -./Prelude/Text/concat - : ./Prelude/Monoid Text -|] ) + (Util.assertTypeChecks "./Prelude/Text/concat : ./Prelude/Monoid Text") _Natural_build_0 :: TestTree _Natural_build_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/build -( λ(natural : Type) -→ λ(succ : natural → natural) -→ λ(zero : natural) -→ succ (succ (succ zero)) -) -|] + e <- Util.code + "./Prelude/Natural/build \n\ + \( λ(natural : Type) \n\ + \→ λ(succ : natural → natural)\n\ + \→ λ(zero : natural) \n\ + \→ succ (succ (succ zero)) \n\ + \) \n" Util.assertNormalizesTo e "+3" ) _Natural_build_1 :: TestTree _Natural_build_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/build -( λ(natural : Type) -→ λ(succ : natural → natural) -→ λ(zero : natural) -→ zero -) -|] + e <- Util.code + "./Prelude/Natural/build \n\ + \( λ(natural : Type) \n\ + \→ λ(succ : natural → natural)\n\ + \→ λ(zero : natural) \n\ + \→ zero \n\ + \) \n" Util.assertNormalizesTo e "+0" ) _Natural_enumerate_0 :: TestTree _Natural_enumerate_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/enumerate +10 -|] + e <- Util.code "./Prelude/Natural/enumerate +10" Util.assertNormalizesTo e "[+0, +1, +2, +3, +4, +5, +6, +7, +8, +9] : List Natural" ) _Natural_enumerate_1 :: TestTree _Natural_enumerate_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/enumerate +0 -|] + e <- Util.code "./Prelude/Natural/enumerate +0" Util.assertNormalizesTo e "[] : List Natural" ) _Natural_even_0 :: TestTree _Natural_even_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/even +3 -|] + e <- Util.code "./Prelude/Natural/even +3" Util.assertNormalizesTo e "False" ) _Natural_even_1 :: TestTree _Natural_even_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/even +0 -|] + e <- Util.code "./Prelude/Natural/even +0" Util.assertNormalizesTo e "True" ) _Natural_fold_0 :: TestTree _Natural_fold_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/fold +3 Natural (λ(x : Natural) → +5 * x) +1 -|] + e <- Util.code "./Prelude/Natural/fold +3 Natural (λ(x : Natural) → +5 * x) +1" Util.assertNormalizesTo e "+125" ) _Natural_fold_1 :: TestTree _Natural_fold_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -λ(zero : Natural) → ./Prelude/Natural/fold +3 Natural (λ(x : Natural) → +5 * x) zero -|] + e <- Util.code + "λ(zero : Natural) → ./Prelude/Natural/fold +3 Natural (λ(x : Natural) → +5 * x) zero" Util.assertNormalizesTo e "λ(zero : Natural) → +5 * +5 * +5 * zero" ) _Natural_fold_2 :: TestTree _Natural_fold_2 = Test.Tasty.HUnit.testCase "Example #2" (do - e <- Util.code [NeatInterpolation.text| - λ(natural : Type) -→ λ(succ : natural → natural) -→ λ(zero : natural) -→ ./Prelude/Natural/fold +3 natural succ zero -|] + e <- Util.code + " λ(natural : Type) \n\ + \→ λ(succ : natural → natural) \n\ + \→ λ(zero : natural) \n\ + \→ ./Prelude/Natural/fold +3 natural succ zero\n" Util.assertNormalizesTo e "λ(natural : Type) → λ(succ : natural → natural) → λ(zero : natural) → succ (succ (succ zero))" ) _Natural_isZero_0 :: TestTree _Natural_isZero_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/isZero +2 -|] + e <- Util.code "./Prelude/Natural/isZero +2" Util.assertNormalizesTo e "False" ) _Natural_isZero_1 :: TestTree _Natural_isZero_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/isZero +0 -|] + e <- Util.code "./Prelude/Natural/isZero +0" Util.assertNormalizesTo e "True" ) _Natural_odd_0 :: TestTree _Natural_odd_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/odd +3 -|] + e <- Util.code "./Prelude/Natural/odd +3" Util.assertNormalizesTo e "True" ) _Natural_odd_1 :: TestTree _Natural_odd_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/odd +0 -|] + e <- Util.code "./Prelude/Natural/odd +0" Util.assertNormalizesTo e "False" ) _Natural_product_0 :: TestTree _Natural_product_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/product ([+2, +3, +5] : List Natural) -|] + e <- Util.code "./Prelude/Natural/product ([+2, +3, +5] : List Natural)" Util.assertNormalizesTo e "+30" ) _Natural_product_1 :: TestTree _Natural_product_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/product ([] : List Natural) -|] + e <- Util.code "./Prelude/Natural/product ([] : List Natural)" Util.assertNormalizesTo e "+1" ) _Natural_show_0 :: TestTree _Natural_show_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/show +3 -|] + e <- Util.code "./Prelude/Natural/show +3" Util.assertNormalizesTo e "\"+3\"" ) _Natural_show_1 :: TestTree _Natural_show_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/show +0 -|] + e <- Util.code "./Prelude/Natural/show +0" Util.assertNormalizesTo e "\"+0\"" ) _Natural_sum_0 :: TestTree _Natural_sum_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/sum ([+2, +3, +5] : List Natural) -|] + e <- Util.code "./Prelude/Natural/sum ([+2, +3, +5] : List Natural)" Util.assertNormalizesTo e "+10" ) _Natural_sum_1 :: TestTree _Natural_sum_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/sum ([] : List Natural) -|] + e <- Util.code "./Prelude/Natural/sum ([] : List Natural)" Util.assertNormalizesTo e "+0" ) _Natural_toInteger_0 :: TestTree _Natural_toInteger_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/toInteger +3 -|] + e <- Util.code "./Prelude/Natural/toInteger +3" Util.assertNormalizesTo e "3" ) _Natural_toInteger_1 :: TestTree _Natural_toInteger_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Natural/toInteger +0 -|] + e <- Util.code "./Prelude/Natural/toInteger +0" Util.assertNormalizesTo e "0" ) _Optional_all_0 :: TestTree _Optional_all_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/all Natural Natural/even ([+3] : Optional Natural) -|] + e <- Util.code "./Prelude/Optional/all Natural Natural/even ([+3] : Optional Natural)" Util.assertNormalizesTo e "False" ) _Optional_all_1 :: TestTree _Optional_all_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/all Natural Natural/even ([] : Optional Natural) -|] + e <- Util.code "./Prelude/Optional/all Natural Natural/even ([] : Optional Natural)" Util.assertNormalizesTo e "True" ) _Optional_any_0 :: TestTree _Optional_any_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/any Natural Natural/even ([+2] : Optional Natural) -|] + e <- Util.code "./Prelude/Optional/any Natural Natural/even ([+2] : Optional Natural)" Util.assertNormalizesTo e "True" ) _Optional_any_1 :: TestTree _Optional_any_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/any Natural Natural/even ([] : Optional Natural) -|] + e <- Util.code "./Prelude/Optional/any Natural Natural/even ([] : Optional Natural)" Util.assertNormalizesTo e "False" ) _Optional_build_0 :: TestTree _Optional_build_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/build -Integer -( λ(optional : Type) -→ λ(just : Integer → optional) -→ λ(nothing : optional) -→ just 1 -) -|] + e <- Util.code + "./Prelude/Optional/build \n\ + \Integer \n\ + \( λ(optional : Type) \n\ + \→ λ(just : Integer → optional)\n\ + \→ λ(nothing : optional) \n\ + \→ just 1 \n\ + \) \n" Util.assertNormalizesTo e "[1] : Optional Integer" ) _Optional_build_1 :: TestTree _Optional_build_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/build -Integer -( λ(optional : Type) -→ λ(just : Integer → optional) -→ λ(nothing : optional) -→ nothing -) -|] + e <- Util.code + "./Prelude/Optional/build \n\ + \Integer \n\ + \( λ(optional : Type) \n\ + \→ λ(just : Integer → optional)\n\ + \→ λ(nothing : optional) \n\ + \→ nothing \n\ + \) \n" Util.assertNormalizesTo e "[] : Optional Integer" ) _Optional_concat_0 :: TestTree _Optional_concat_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/concat Integer ([[1] : Optional Integer] : Optional (Optional Integer)) -|] + e <- Util.code + "./Prelude/Optional/concat Integer ([[1] : Optional Integer] : Optional (Optional Integer))" Util.assertNormalizesTo e "[1] : Optional Integer" ) _Optional_concat_1 :: TestTree _Optional_concat_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/concat Integer ([[] : Optional Integer] : Optional (Optional Integer)) -|] + e <- Util.code + "./Prelude/Optional/concat Integer ([[] : Optional Integer] : Optional (Optional Integer))" Util.assertNormalizesTo e "[] : Optional Integer" ) _Optional_concat_2 :: TestTree _Optional_concat_2 = Test.Tasty.HUnit.testCase "Example #2" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/concat Integer ([] : Optional (Optional Integer)) -|] + e <- Util.code "./Prelude/Optional/concat Integer ([] : Optional (Optional Integer))" Util.assertNormalizesTo e "[] : Optional Integer" ) _Optional_filter_0 :: TestTree _Optional_filter_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/filter Natural Natural/even ([+2] : Optional Natural) -|] + e <- Util.code + "./Prelude/Optional/filter Natural Natural/even ([+2] : Optional Natural)" Util.assertNormalizesTo e "[+2] : Optional Natural" ) _Optional_filter_1 :: TestTree _Optional_filter_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/filter Natural Natural/odd ([+2] : Optional Natural) -|] + e <- Util.code "./Prelude/Optional/filter Natural Natural/odd ([+2] : Optional Natural)" Util.assertNormalizesTo e "[] : Optional Natural" ) _Optional_fold_0 :: TestTree _Optional_fold_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/fold Integer ([2] : Optional Integer) Integer (λ(x : Integer) → x) 0 -|] + e <- Util.code + "./Prelude/Optional/fold Integer ([2] : Optional Integer) Integer (λ(x : Integer) → x) 0" Util.assertNormalizesTo e "2" ) _Optional_fold_1 :: TestTree _Optional_fold_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/fold Integer ([] : Optional Integer) Integer (λ(x : Integer) → x) 0 -|] + e <- Util.code + "./Prelude/Optional/fold Integer ([] : Optional Integer) Integer (λ(x : Integer) → x) 0" Util.assertNormalizesTo e "0" ) _Optional_head_0 :: TestTree _Optional_head_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/head -Integer -( [[] : Optional Integer, [1] : Optional Integer, [2] : Optional Integer] - : List (Optional Integer) -) -|] + e <- Util.code + "./Prelude/Optional/head \n\ + \Integer \n\ + \( [[] : Optional Integer, [1] : Optional Integer, [2] : Optional Integer]\n\ + \ : List (Optional Integer) \n\ + \) \n" Util.assertNormalizesTo e "[1] : Optional Integer" ) _Optional_head_1 :: TestTree _Optional_head_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/head -Integer -([[] : Optional Integer, [] : Optional Integer] : List (Optional Integer)) -|] + e <- Util.code + "./Prelude/Optional/head \n\ + \Integer \n\ + \([[] : Optional Integer, [] : Optional Integer] : List (Optional Integer))\n" Util.assertNormalizesTo e "[] : Optional Integer" ) _Optional_head_2 :: TestTree _Optional_head_2 = Test.Tasty.HUnit.testCase "Example #2" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/head Integer ([] : List (Optional Integer)) -|] + e <- Util.code "./Prelude/Optional/head Integer ([] : List (Optional Integer))" Util.assertNormalizesTo e "[] : Optional Integer" ) _Optional_last_0 :: TestTree _Optional_last_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/last -Integer -( [[] : Optional Integer, [1] : Optional Integer, [2] : Optional Integer] - : List (Optional Integer) -) -|] + e <- Util.code + "./Prelude/Optional/last \n\ + \Integer \n\ + \( [[] : Optional Integer, [1] : Optional Integer, [2] : Optional Integer]\n\ + \ : List (Optional Integer) \n\ + \) \n" Util.assertNormalizesTo e "[2] : Optional Integer" ) _Optional_last_1 :: TestTree _Optional_last_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/last -Integer -([[] : Optional Integer, [] : Optional Integer] : List (Optional Integer)) -|] + e <- Util.code + "./Prelude/Optional/last \n\ + \Integer \n\ + \([[] : Optional Integer, [] : Optional Integer] : List (Optional Integer))\n" Util.assertNormalizesTo e "[] : Optional Integer" ) _Optional_last_2 :: TestTree _Optional_last_2 = Test.Tasty.HUnit.testCase "Example #2" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/last Integer ([] : List (Optional Integer)) -|] + e <- Util.code "./Prelude/Optional/last Integer ([] : List (Optional Integer))" Util.assertNormalizesTo e "[] : Optional Integer" ) _Optional_map_0 :: TestTree _Optional_map_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/map Natural Bool Natural/even ([+3] : Optional Natural) -|] + e <- Util.code + "./Prelude/Optional/map Natural Bool Natural/even ([+3] : Optional Natural)" Util.assertNormalizesTo e "[False] : Optional Bool" ) _Optional_length_0 :: TestTree _Optional_length_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/length Integer ([2] : Optional Integer) -|] + e <- Util.code "./Prelude/Optional/length Integer ([2] : Optional Integer)" Util.assertNormalizesTo e "+1" ) _Optional_length_1 :: TestTree _Optional_length_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/length Integer ([] : Optional Integer) -|] + e <- Util.code "./Prelude/Optional/length Integer ([] : Optional Integer)" Util.assertNormalizesTo e "+0" ) _Optional_map_1 :: TestTree _Optional_map_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/map Natural Bool Natural/even ([] : Optional Natural) -|] + e <- Util.code + "./Prelude/Optional/map Natural Bool Natural/even ([] : Optional Natural)" Util.assertNormalizesTo e "[] : Optional Bool" ) _Optional_null_0 :: TestTree _Optional_null_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/null Integer ([2] : Optional Integer) -|] + e <- Util.code "./Prelude/Optional/null Integer ([2] : Optional Integer)" Util.assertNormalizesTo e "False" ) _Optional_null_1 :: TestTree _Optional_null_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/null Integer ([] : Optional Integer) -|] + e <- Util.code "./Prelude/Optional/null Integer ([] : Optional Integer)" Util.assertNormalizesTo e "True" ) _Optional_toList_0 :: TestTree _Optional_toList_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/toList Integer ([1] : Optional Integer) -|] + e <- Util.code "./Prelude/Optional/toList Integer ([1] : Optional Integer)" Util.assertNormalizesTo e "[1] : List Integer" ) _Optional_toList_1 :: TestTree _Optional_toList_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/toList Integer ([] : Optional Integer) -|] + e <- Util.code "./Prelude/Optional/toList Integer ([] : Optional Integer)" Util.assertNormalizesTo e "[] : List Integer" ) _Optional_unzip_0 :: TestTree _Optional_unzip_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/unzip -Text -Bool -([{ _1 = "ABC", _2 = True }] : Optional { _1 : Text, _2 : Bool }) -|] + e <- Util.code + "./Prelude/Optional/unzip \n\ + \Text \n\ + \Bool \n\ + \([{ _1 = \"ABC\", _2 = True }] : Optional { _1 : Text, _2 : Bool })\n" Util.assertNormalizesTo e "{ _1 = [\"ABC\"] : Optional Text, _2 = [True] : Optional Bool }" ) _Optional_unzip_1 :: TestTree _Optional_unzip_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Optional/unzip Text Bool ([] : Optional { _1 : Text, _2 : Bool }) -|] + e <- Util.code + "./Prelude/Optional/unzip Text Bool ([] : Optional { _1 : Text, _2 : Bool })" Util.assertNormalizesTo e "{ _1 = [] : Optional Text, _2 = [] : Optional Bool }" ) _Text_concat_0 :: TestTree _Text_concat_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Text/concat (["ABC", "DEF", "GHI"] : List Text) -|] + e <- Util.code "./Prelude/Text/concat ([\"ABC\", \"DEF\", \"GHI\"] : List Text)" Util.assertNormalizesTo e "\"ABCDEFGHI\"" ) _Text_concat_1 :: TestTree _Text_concat_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Text/concat ([] : List Text) -|] + e <- Util.code "./Prelude/Text/concat ([] : List Text)" Util.assertNormalizesTo e "\"\"" ) _Text_concatMap_0 :: TestTree _Text_concatMap_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Text//concatMap Integer (λ(n : Integer) → "${Integer/show n} ") [0, 1, 2] -|] + e <- Util.code + "./Prelude/Text/concatMap Integer (λ(n : Integer) → \"${Integer/show n} \") [0, 1, 2]" Util.assertNormalizesTo e "\"0 1 2 \"" ) _Text_concatMap_1 :: TestTree _Text_concatMap_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Text/concatMap Integer (λ(n : Integer) → "${Integer/show n} ") ([] : List Integer) -|] + e <- Util.code + "./Prelude/Text/concatMap Integer (λ(n : Integer) → \"${Integer/show n} \") ([] : List Integer)" Util.assertNormalizesTo e "\"\"" ) _Text_concatMapSep_0 :: TestTree _Text_concatMapSep_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Text/concatMapSep ", " Integer Integer/show [0, 1, 2] -|] + e <- Util.code "./Prelude/Text/concatMapSep \", \" Integer Integer/show [0, 1, 2]" Util.assertNormalizesTo e "\"0, 1, 2\"" ) _Text_concatMapSep_1 :: TestTree _Text_concatMapSep_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Text/concatMapSep ", " Integer Integer/show ([] : List Integer) -|] + e <- Util.code + "./Prelude/Text/concatMapSep \", \" Integer Integer/show ([] : List Integer)" Util.assertNormalizesTo e "\"\"" ) _Text_concatSep_0 :: TestTree _Text_concatSep_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Text/concatSep ", " ["ABC", "DEF", "GHI"] -|] + e <- Util.code "./Prelude/Text/concatSep \", \" [\"ABC\", \"DEF\", \"GHI\"]" Util.assertNormalizesTo e "\"ABC, DEF, GHI\"" ) _Text_concatSep_1 :: TestTree _Text_concatSep_1 = Test.Tasty.HUnit.testCase "Example #1" (do - e <- Util.code [NeatInterpolation.text| -./Prelude/Text/concatSep ", " ([] : List Text) -|] + e <- Util.code "./Prelude/Text/concatSep \", \" ([] : List Text)" Util.assertNormalizesTo e "\"\"" ) diff --git a/tests/Normalization.hs b/tests/Normalization.hs --- a/tests/Normalization.hs +++ b/tests/Normalization.hs @@ -1,19 +1,20 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} module Normalization (normalizationTests) where -import Dhall.Core -import qualified NeatInterpolation -import Test.Tasty -import Test.Tasty.HUnit -import Util (code, normalize', assertNormalizesTo, assertNormalized) +import Data.Monoid ((<>)) +import Dhall.Core +import Dhall.Context +import Test.Tasty +import Test.Tasty.HUnit +import Util normalizationTests :: TestTree normalizationTests = testGroup "normalization" [ constantFolding , conversions , fusion + , customization ] constantFolding :: TestTree @@ -29,6 +30,36 @@ , naturalToInteger ] +customization :: TestTree +customization = testGroup "customization" + [simpleCustomization + ,nestedReduction] + +simpleCustomization :: TestTree +simpleCustomization = testCase "simpleCustomization" $ do + let tyCtx = insert "min" (Pi "_" Natural (Pi "_" Natural Natural)) empty + valCtx e = case e of + (App (App (Var (V "min" 0)) (NaturalLit x)) (NaturalLit y)) -> Just (NaturalLit (min x y)) + _ -> Nothing + e <- codeWith tyCtx "min (min +11 +12) +8 + +1" + assertNormalizesToWith valCtx e "+9" + +nestedReduction :: TestTree +nestedReduction = testCase "doubleReduction" $ do + minType <- insert "min" <$> code "Natural → Natural → Natural" + fiveorlessType <- insert "fiveorless" <$> code "Natural → Natural" + wurbleType <- insert "wurble" <$> code "Natural → Integer" + let tyCtx = minType . fiveorlessType . wurbleType $ empty + valCtx e = case e of + (App (App (Var (V "min" 0)) (NaturalLit x)) (NaturalLit y)) -> Just (NaturalLit (min x y)) + (App (Var (V "wurble" 0)) (NaturalLit x)) -> Just + (App (Var (V "fiveorless" 0)) (NaturalPlus (NaturalLit x) (NaturalLit 2))) + (App (Var (V "fiveorless" 0)) (NaturalLit x)) -> Just + (App (App (Var (V "min" 0)) (NaturalLit x)) (NaturalPlus (NaturalLit 3) (NaturalLit 2))) + _ -> Nothing + e <- codeWith tyCtx "wurble +6" + assertNormalizesToWith valCtx e "+5" + naturalPlus :: TestTree naturalPlus = testCase "natural plus" $ do e <- code "+1 + +2" @@ -58,9 +89,7 @@ optionalFold :: TestTree optionalFold = testGroup "Optional/fold" [ just, nothing ] where test label inp out = testCase label $ do - e <- code [NeatInterpolation.text| - Optional/fold Text ([$inp] : Optional Text) Natural (λ(j : Text) → +1) +2 - |] + e <- code ("Optional/fold Text ([" <> inp <> "] : Optional Text) Natural (λ(j : Text) → +1) +2") e `assertNormalizesTo` out just = test "just" "\"foo\"" "+1" nothing = test "nothing" "" "+2" @@ -73,42 +102,39 @@ optionalBuild1 :: TestTree optionalBuild1 = testCase "reducible" $ do - e <- code [NeatInterpolation.text| -Optional/build -Natural -( λ(optional : Type) -→ λ(just : Natural → optional) -→ λ(nothing : optional) -→ just +1 -) -|] + e <- code + "Optional/build \n\ + \Natural \n\ + \( λ(optional : Type) \n\ + \→ λ(just : Natural → optional)\n\ + \→ λ(nothing : optional) \n\ + \→ just +1 \n\ + \) \n" e `assertNormalizesTo` "[+1] : Optional Natural" optionalBuildShadowing :: TestTree optionalBuildShadowing = testCase "handles shadowing" $ do - e <- code [NeatInterpolation.text| -Optional/build -Integer -( λ(optional : Type) -→ λ(x : Integer → optional) -→ λ(x : optional) -→ x@1 1 -) -|] + e <- code + "Optional/build \n\ + \Integer \n\ + \( λ(optional : Type) \n\ + \→ λ(x : Integer → optional)\n\ + \→ λ(x : optional) \n\ + \→ x@1 1 \n\ + \) \n" e `assertNormalizesTo` "[1] : Optional Integer" optionalBuildIrreducible :: TestTree optionalBuildIrreducible = testCase "irreducible" $ do - e <- code [NeatInterpolation.text| - λ(id : ∀(a : Type) → a → a) -→ Optional/build - Bool - ( λ(optional : Type) - → λ(just : Bool → optional) - → λ(nothing : optional) - → id optional (just True) - ) -|] + e <- code + " λ(id : ∀(a : Type) → a → a) \n\ + \→ Optional/build \n\ + \ Bool \n\ + \ ( λ(optional : Type) \n\ + \ → λ(just : Bool → optional)\n\ + \ → λ(nothing : optional) \n\ + \ → id optional (just True) \n\ + \ ) \n" assertNormalized e fusion :: TestTree @@ -118,39 +144,36 @@ fuseOptionalBF :: TestTree fuseOptionalBF = testCase "fold . build" $ do - e0 <- code [NeatInterpolation.text| - λ( f - : ∀(optional : Type) - → ∀(just : Text → optional) - → ∀(nothing : optional) - → optional - ) -→ Optional/fold - Text - ( Optional/build - Text - f - ) -|] - e1 <- code [NeatInterpolation.text| - λ( f - : ∀(optional : Type) - → ∀(just : Text → optional) - → ∀(nothing : optional) - → optional - ) -→ f -|] + e0 <- code + " λ( f \n\ + \ : ∀(optional : Type) \n\ + \ → ∀(just : Text → optional)\n\ + \ → ∀(nothing : optional) \n\ + \ → optional \n\ + \ ) \n\ + \→ Optional/fold \n\ + \ Text \n\ + \ ( Optional/build \n\ + \ Text \n\ + \ f \n\ + \ ) \n" + e1 <- code + " λ( f \n\ + \ : ∀(optional : Type) \n\ + \ → ∀(just : Text → optional)\n\ + \ → ∀(nothing : optional) \n\ + \ → optional \n\ + \ ) \n\ + \→ f \n" e0 `assertNormalizesTo` (Dhall.Core.pretty e1) fuseOptionalFB :: TestTree fuseOptionalFB = testCase "build . fold" $ do - test <- code [NeatInterpolation.text| -Optional/build -Text -( Optional/fold - Text - (["foo"] : Optional Text) -) -|] + test <- code + "Optional/build \n\ + \Text \n\ + \( Optional/fold \n\ + \ Text \n\ + \ ([\"foo\"] : Optional Text)\n\ + \) \n" test `assertNormalizesTo` "[\"foo\"] : Optional Text" diff --git a/tests/Tutorial.hs b/tests/Tutorial.hs --- a/tests/Tutorial.hs +++ b/tests/Tutorial.hs @@ -1,14 +1,19 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} module Tutorial where -import qualified NeatInterpolation +import qualified Data.Vector +import qualified Dhall import qualified Test.Tasty import qualified Test.Tasty.HUnit import qualified Util +import Dhall (Inject) +import GHC.Generics (Generic) import Test.Tasty (TestTree) +import Test.Tasty.HUnit ((@?=)) tutorialTests :: TestTree tutorialTests = @@ -17,24 +22,48 @@ [ _Interpolation_0 , _Interpolation_1 ] + , Test.Tasty.testGroup "Functions" + [ _Functions_0 + , _Functions_1 + , _Functions_2 + ] ] _Interpolation_0 :: TestTree _Interpolation_0 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| - let name = "John Doe" -in let age = 21 -in "My name is $${name} and my age is $${Integer/show age}" -|] + e <- Util.code + " let name = \"John Doe\" \n\ + \in let age = 21 \n\ + \in \"My name is ${name} and my age is ${Integer/show age}\"\n" Util.assertNormalizesTo e "\"My name is John Doe and my age is 21\"" ) _Interpolation_1 :: TestTree -_Interpolation_1 = Test.Tasty.HUnit.testCase "Example #0" (do - e <- Util.code [NeatInterpolation.text| -'' - for file in *; do - echo "Found ''$${file}" - done -'' -|] +_Interpolation_1 = Test.Tasty.HUnit.testCase "Example #1" (do + e <- Util.code + "'' \n\ + \ for file in *; do \n\ + \ echo \"Found ''${file}\"\n\ + \ done \n\ + \'' \n" Util.assertNormalized e ) + +_Functions_0 :: TestTree +_Functions_0 = Test.Tasty.HUnit.testCase "Example #0" (do + let text = "\\(n : Bool) -> [ n && True, n && False, n || True, n || False ]" + makeBools <- Dhall.input Dhall.auto text + makeBools True @?= Data.Vector.fromList [True,False,True,True] ) + +_Functions_1 :: TestTree +_Functions_1 = Test.Tasty.HUnit.testCase "Example #1" (do + let text = "λ(x : Bool) → λ(y : Bool) → x && y" + makeBools <- Dhall.input Dhall.auto text + makeBools True False @?= False ) + +data Example0 = Example0 { foo :: Bool, bar :: Bool } + deriving (Generic, Inject) + +_Functions_2 :: TestTree +_Functions_2 = Test.Tasty.HUnit.testCase "Example #2" (do + f <- Dhall.input Dhall.auto "λ(r : { foo : Bool, bar : Bool }) → r.foo && r.bar" + f (Example0 { foo = True, bar = False }) @?= False + f (Example0 { foo = True, bar = True }) @?= True ) diff --git a/tests/Util.hs b/tests/Util.hs --- a/tests/Util.hs +++ b/tests/Util.hs @@ -1,19 +1,25 @@ -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Util ( code + , codeWith , normalize' + , normalizeWith' , assertNormalizesTo + , assertNormalizesToWith , assertNormalized , assertTypeChecks ) where import qualified Control.Exception import qualified Data.Functor +import Data.Bifunctor (first) import Data.Text (Text) import qualified Data.Text.Lazy import qualified Dhall.Core -import Dhall.Core (Expr) +import Dhall.Core (Expr, Normalizer) +import qualified Dhall.Context +import Dhall.Context (Context) import qualified Dhall.Import import qualified Dhall.Parser import Dhall.Parser (Src) @@ -24,22 +30,34 @@ normalize' :: Expr Src X -> Data.Text.Lazy.Text normalize' = Dhall.Core.pretty . Dhall.Core.normalize +normalizeWith' :: Normalizer X -> Expr Src X -> Data.Text.Lazy.Text +normalizeWith' ctx = Dhall.Core.pretty . Dhall.Core.normalizeWith ctx + code :: Data.Text.Text -> IO (Expr Src X) -code strictText = do +code = codeWith Dhall.Context.empty + +codeWith :: Context (Expr Src X) -> Data.Text.Text -> IO (Expr Src X) +codeWith ctx strictText = do let lazyText = Data.Text.Lazy.fromStrict strictText expr0 <- case Dhall.Parser.exprFromText mempty lazyText of Left parseError -> Control.Exception.throwIO parseError Right expr0 -> return expr0 expr1 <- Dhall.Import.load expr0 - case Dhall.TypeCheck.typeOf expr1 of + case Dhall.TypeCheck.typeWith ctx expr1 of Left typeError -> Control.Exception.throwIO typeError Right _ -> return () return expr1 assertNormalizesTo :: Expr Src X -> Data.Text.Lazy.Text -> IO () -assertNormalizesTo e expected = do +assertNormalizesTo e expected = do assertBool msg (not $ Dhall.Core.isNormalized e) normalize' e @?= expected + where msg = "Given expression is already in normal form" + +assertNormalizesToWith :: Normalizer X -> Expr Src X -> Data.Text.Lazy.Text -> IO () +assertNormalizesToWith ctx e expected = do + assertBool msg (not $ Dhall.Core.isNormalizedWith ctx (first (const ()) e)) + normalizeWith' ctx e @?= expected where msg = "Given expression is already in normal form" assertNormalized :: Expr Src X -> IO ()