{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedLists   #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards     #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE ViewPatterns      #-}

-- | This module contains the implementation of the @dhall lint@ command

module Dhall.Lint
    ( -- * Lint
      lint
    , removeUnusedBindings
    , fixAssert
    , fixParentPath
    , addPreludeExtensions
    , removeLetInLet
    , useToMap
    ) where

import Control.Applicative ((<|>))

import Dhall.Syntax
    ( Binding (..)
    , Chunks (..)
    , Directory (..)
    , Expr (..)
    , File (..)
    , FilePrefix (..)
    , Import (..)
    , ImportHashed (..)
    , ImportType (..)
    , URL (..)
    , Var (..)
    , subExpressions
    )

import qualified Data.Foldable      as Foldable
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text          as Text
import qualified Dhall.Core         as Core
import qualified Dhall.Map          as Map
import qualified Dhall.Optics
import qualified Lens.Family

{-| Automatically improve a Dhall expression

    Currently this:

    * removes unused @let@ bindings with 'removeUnusedBindings'.
    * fixes @let a = x ≡ y@ to be @let a = assert : x ≡ y@
    * consolidates nested @let@ bindings to use a multiple-@let@ binding with 'removeLetInLet'
    * fixes paths of the form @.\/..\/foo@ to @..\/foo@
-}
lint :: Expr s Import -> Expr s Import
lint :: Expr s Import -> Expr s Import
lint =  ASetter
  (Expr s Import) (Expr s Import) (Expr s Import) (Expr s Import)
-> (Expr s Import -> Maybe (Expr s Import))
-> Expr s Import
-> Expr s Import
forall a b. ASetter a b a b -> (b -> Maybe a) -> a -> b
Dhall.Optics.rewriteOf ASetter
  (Expr s Import) (Expr s Import) (Expr s Import) (Expr s Import)
forall (f :: * -> *) s a.
Applicative f =>
(Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a)
subExpressions Expr s Import -> Maybe (Expr s Import)
forall s. Expr s Import -> Maybe (Expr s Import)
rewrite
  where
    rewrite :: Expr s Import -> Maybe (Expr s Import)
rewrite Expr s Import
e =
            Expr s Import -> Maybe (Expr s Import)
forall s a. Expr s a -> Maybe (Expr s a)
fixAssert                Expr s Import
e
        Maybe (Expr s Import)
-> Maybe (Expr s Import) -> Maybe (Expr s Import)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Expr s Import -> Maybe (Expr s Import)
forall a s. Eq a => Expr s a -> Maybe (Expr s a)
removeUnusedBindings     Expr s Import
e
        Maybe (Expr s Import)
-> Maybe (Expr s Import) -> Maybe (Expr s Import)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Expr s Import -> Maybe (Expr s Import)
forall s. Expr s Import -> Maybe (Expr s Import)
fixParentPath            Expr s Import
e
        Maybe (Expr s Import)
-> Maybe (Expr s Import) -> Maybe (Expr s Import)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Expr s Import -> Maybe (Expr s Import)
forall s a. Expr s a -> Maybe (Expr s a)
removeLetInLet           Expr s Import
e
        Maybe (Expr s Import)
-> Maybe (Expr s Import) -> Maybe (Expr s Import)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Expr s Import -> Maybe (Expr s Import)
forall s. Expr s Import -> Maybe (Expr s Import)
addPreludeExtensions     Expr s Import
e

-- | Remove unused `Let` bindings.
removeUnusedBindings :: Eq a => Expr s a -> Maybe (Expr s a)
-- Don't remove assertions!
removeUnusedBindings :: Expr s a -> Maybe (Expr s a)
removeUnusedBindings (Let (Binding Maybe s
_ Text
_ Maybe s
_ Maybe (Maybe s, Expr s a)
_ Maybe s
_ Expr s a
e) Expr s a
_)
    | Expr s a -> Bool
forall s a. Expr s a -> Bool
isOrContainsAssert Expr s a
e = Maybe (Expr s a)
forall a. Maybe a
Nothing
removeUnusedBindings (Let (Binding Maybe s
_ Text
a Maybe s
_ Maybe (Maybe s, Expr s a)
_ Maybe s
_ Expr s a
_) Expr s a
d)
    | Bool -> Bool
not (Text -> Int -> Var
V Text
a Int
0 Var -> Expr s a -> Bool
forall a s. Eq a => Var -> Expr s a -> Bool
`Core.freeIn` Expr s a
d) =
        Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just (Int -> Var -> Expr s a -> Expr s a
forall s a. Int -> Var -> Expr s a -> Expr s a
Core.shift (-Int
1) (Text -> Int -> Var
V Text
a Int
0) Expr s a
d)
removeUnusedBindings Expr s a
_ = Maybe (Expr s a)
forall a. Maybe a
Nothing

-- | Fix `Let` bindings  that the user probably meant to be @assert@s
fixAssert :: Expr s a -> Maybe (Expr s a)
fixAssert :: Expr s a -> Maybe (Expr s a)
fixAssert (Let (Binding { value :: forall s a. Binding s a -> Expr s a
value = v :: Expr s a
v@(Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a
Core.shallowDenote -> Equivalent {}), Maybe s
Maybe (Maybe s, Expr s a)
Text
bindingSrc2 :: forall s a. Binding s a -> Maybe s
annotation :: forall s a. Binding s a -> Maybe (Maybe s, Expr s a)
bindingSrc1 :: forall s a. Binding s a -> Maybe s
variable :: forall s a. Binding s a -> Text
bindingSrc0 :: forall s a. Binding s a -> Maybe s
bindingSrc2 :: Maybe s
annotation :: Maybe (Maybe s, Expr s a)
bindingSrc1 :: Maybe s
variable :: Text
bindingSrc0 :: Maybe s
..}) Expr s a
body) =
    Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just (Binding s a -> Expr s a -> Expr s a
forall s a. Binding s a -> Expr s a -> Expr s a
Let (Binding :: forall s a.
Maybe s
-> Text
-> Maybe s
-> Maybe (Maybe s, Expr s a)
-> Maybe s
-> Expr s a
-> Binding s a
Binding { value :: Expr s a
value = Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a
Assert Expr s a
v, Maybe s
Maybe (Maybe s, Expr s a)
Text
bindingSrc2 :: Maybe s
annotation :: Maybe (Maybe s, Expr s a)
bindingSrc1 :: Maybe s
variable :: Text
bindingSrc0 :: Maybe s
bindingSrc2 :: Maybe s
annotation :: Maybe (Maybe s, Expr s a)
bindingSrc1 :: Maybe s
variable :: Text
bindingSrc0 :: Maybe s
.. }) Expr s a
body)
fixAssert (Let Binding s a
binding body :: Expr s a
body@(Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a
Core.shallowDenote -> Equivalent {})) =
    Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just (Binding s a -> Expr s a -> Expr s a
forall s a. Binding s a -> Expr s a -> Expr s a
Let Binding s a
binding (Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a
Assert Expr s a
body))
fixAssert Expr s a
_ =
    Maybe (Expr s a)
forall a. Maybe a
Nothing

-- | This transforms @.\/..\/foo@ into @..\/foo@
fixParentPath :: Expr s Import -> Maybe (Expr s Import)
fixParentPath :: Expr s Import -> Maybe (Expr s Import)
fixParentPath (Embed Import
oldImport) = do
    let Import{ImportHashed
ImportMode
importMode :: Import -> ImportMode
importHashed :: Import -> ImportHashed
importMode :: ImportMode
importHashed :: ImportHashed
..} = Import
oldImport

    let ImportHashed{Maybe SHA256Digest
ImportType
importType :: ImportHashed -> ImportType
hash :: ImportHashed -> Maybe SHA256Digest
importType :: ImportType
hash :: Maybe SHA256Digest
..} = ImportHashed
importHashed

    case ImportType
importType of
        Local FilePrefix
Here File{ directory :: File -> Directory
directory = Directory { [Text]
components :: Directory -> [Text]
components :: [Text]
components }, Text
file :: File -> Text
file :: Text
.. }
            | Just NonEmpty Text
nonEmpty <- [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [Text]
components
            , NonEmpty Text -> Text
forall a. NonEmpty a -> a
NonEmpty.last NonEmpty Text
nonEmpty Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
".." -> do
                let newDirectory :: Directory
newDirectory =
                        Directory :: [Text] -> Directory
Directory { components :: [Text]
components = NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NonEmpty.init NonEmpty Text
nonEmpty }

                let newImportType :: ImportType
newImportType =
                        FilePrefix -> File -> ImportType
Local FilePrefix
Parent File :: Directory -> Text -> File
File{ directory :: Directory
directory = Directory
newDirectory, Text
file :: Text
file :: Text
.. }

                let newImportHashed :: ImportHashed
newImportHashed =
                        ImportHashed :: Maybe SHA256Digest -> ImportType -> ImportHashed
ImportHashed { importType :: ImportType
importType = ImportType
newImportType, Maybe SHA256Digest
hash :: Maybe SHA256Digest
hash :: Maybe SHA256Digest
.. }

                let newImport :: Import
newImport = Import :: ImportHashed -> ImportMode -> Import
Import { importHashed :: ImportHashed
importHashed = ImportHashed
newImportHashed, ImportMode
importMode :: ImportMode
importMode :: ImportMode
.. }

                Expr s Import -> Maybe (Expr s Import)
forall a. a -> Maybe a
Just (Import -> Expr s Import
forall s a. a -> Expr s a
Embed Import
newImport)
        ImportType
_ ->
            Maybe (Expr s Import)
forall a. Maybe a
Nothing
fixParentPath Expr s Import
_  = Maybe (Expr s Import)
forall a. Maybe a
Nothing

{-| This transforms @https://prelude.dhall-lang.org/…/foo@ to
    @https://prelude.dhall-lang.org/…/foo.dhall@
-}
addPreludeExtensions :: Expr s Import -> Maybe (Expr s Import)
addPreludeExtensions :: Expr s Import -> Maybe (Expr s Import)
addPreludeExtensions (Embed Import
oldImport) = do
    let Import{ importHashed :: Import -> ImportHashed
importHashed = ImportHashed
oldImportHashed, ImportMode
importMode :: ImportMode
importMode :: Import -> ImportMode
.. } = Import
oldImport

    let ImportHashed{ importType :: ImportHashed -> ImportType
importType = ImportType
oldImportType, Maybe SHA256Digest
hash :: Maybe SHA256Digest
hash :: ImportHashed -> Maybe SHA256Digest
.. } = ImportHashed
oldImportHashed

    case ImportType
oldImportType of
        Remote URL{ path :: URL -> File
path = File
oldPath, Maybe Text
Maybe (Expr Src Import)
Text
Scheme
headers :: URL -> Maybe (Expr Src Import)
query :: URL -> Maybe Text
authority :: URL -> Text
scheme :: URL -> Scheme
headers :: Maybe (Expr Src Import)
query :: Maybe Text
authority :: Text
scheme :: Scheme
..}
            | Text
authority Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"prelude.dhall-lang.org" ->
                case File
oldPath of
                    File{ file :: File -> Text
file = Text
oldFile, Directory
directory :: Directory
directory :: File -> Directory
.. }
                        | Bool -> Bool
not (Text -> Text -> Bool
Text.isSuffixOf Text
".dhall" Text
oldFile) -> do
                            let newFile :: Text
newFile = Text
oldFile Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".dhall"

                            let newPath :: File
newPath = File :: Directory -> Text -> File
File{ file :: Text
file = Text
newFile, Directory
directory :: Directory
directory :: Directory
.. }

                            let newImportType :: ImportType
newImportType = URL -> ImportType
Remote URL :: Scheme
-> Text -> File -> Maybe Text -> Maybe (Expr Src Import) -> URL
URL{ path :: File
path = File
newPath, Maybe Text
Maybe (Expr Src Import)
Text
Scheme
headers :: Maybe (Expr Src Import)
query :: Maybe Text
authority :: Text
scheme :: Scheme
headers :: Maybe (Expr Src Import)
query :: Maybe Text
authority :: Text
scheme :: Scheme
.. }

                            let newImportHashed :: ImportHashed
newImportHashed =
                                    ImportHashed :: Maybe SHA256Digest -> ImportType -> ImportHashed
ImportHashed{ importType :: ImportType
importType = ImportType
newImportType, Maybe SHA256Digest
hash :: Maybe SHA256Digest
hash :: Maybe SHA256Digest
.. }

                            let newImport :: Import
newImport =
                                    Import :: ImportHashed -> ImportMode -> Import
Import{ importHashed :: ImportHashed
importHashed = ImportHashed
newImportHashed, ImportMode
importMode :: ImportMode
importMode :: ImportMode
.. }

                            Expr s Import -> Maybe (Expr s Import)
forall (m :: * -> *) a. Monad m => a -> m a
return (Import -> Expr s Import
forall s a. a -> Expr s a
Embed Import
newImport)
                    File
_ ->
                        Maybe (Expr s Import)
forall a. Maybe a
Nothing
        ImportType
_ -> do
            Maybe (Expr s Import)
forall a. Maybe a
Nothing
addPreludeExtensions Expr s Import
_ = Maybe (Expr s Import)
forall a. Maybe a
Nothing

isOrContainsAssert :: Expr s a -> Bool
isOrContainsAssert :: Expr s a -> Bool
isOrContainsAssert (Assert Expr s a
_) = Bool
True
isOrContainsAssert Expr s a
e = FoldLike Any (Expr s a) (Expr s a) (Expr s a) (Expr s a)
-> (Expr s a -> Bool) -> Expr s a -> Bool
forall s t a b. FoldLike Any s t a b -> (a -> Bool) -> s -> Bool
Lens.Family.anyOf FoldLike Any (Expr s a) (Expr s a) (Expr s a) (Expr s a)
forall (f :: * -> *) s a.
Applicative f =>
(Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a)
subExpressions Expr s a -> Bool
forall s a. Expr s a -> Bool
isOrContainsAssert Expr s a
e

-- | The difference between
--
-- > let x = 1 let y = 2 in x + y
--
-- and
--
-- > let x = 1 in let y = 2 in x + y
--
-- is that in the second expression, the inner 'Let' is wrapped by a 'Note'.
--
-- We remove such a 'Note' in order to consolidate nested let-blocks into a
-- single one.
removeLetInLet :: Expr s a -> Maybe (Expr s a)
removeLetInLet :: Expr s a -> Maybe (Expr s a)
removeLetInLet (Let Binding s a
binding (Note s
_ l :: Expr s a
l@Let{})) = Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just (Binding s a -> Expr s a -> Expr s a
forall s a. Binding s a -> Expr s a -> Expr s a
Let Binding s a
binding Expr s a
l)
removeLetInLet Expr s a
_ = Maybe (Expr s a)
forall a. Maybe a
Nothing

-- | This replaces a record of key-value pairs with the equivalent use of
--   @toMap@
--
-- This is currently not used by @dhall lint@ because this would sort @Map@
-- keys, which is not necessarily a behavior-preserving change, but is still
-- made available as a convenient rewrite rule.  For example,
-- @{json,yaml}-to-dhall@ use this rewrite to simplify their output.
useToMap :: Expr s a -> Maybe (Expr s a)
useToMap :: Expr s a -> Maybe (Expr s a)
useToMap
    (ListLit
        t :: Maybe (Expr s a)
t@(Just
            (Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a
Core.shallowDenote -> App
                (Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a
Core.shallowDenote -> Expr s a
List)
                (Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a
Core.shallowDenote -> Record
                    (Map Text (RecordField s a) -> Map Text (RecordField s a)
forall k v. Map k v -> Map k v
Map.sort ->
                        [ ("mapKey", Core.shallowDenote . Core.recordFieldValue -> Text)
                        , ("mapValue", _)
                        ]
                    )
                )
            )
        )
        []
    ) =
        Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just (Expr s a -> Maybe (Expr s a) -> Expr s a
forall s a. Expr s a -> Maybe (Expr s a) -> Expr s a
ToMap (Map Text (RecordField s a) -> Expr s a
forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit []) Maybe (Expr s a)
t)
useToMap (ListLit Maybe (Expr s a)
_ Seq (Expr s a)
keyValues)
    | Bool -> Bool
not (Seq (Expr s a) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq (Expr s a)
keyValues)
    , Just Seq (Text, RecordField s a)
keyValues' <- (Expr s a -> Maybe (Text, RecordField s a))
-> Seq (Expr s a) -> Maybe (Seq (Text, RecordField s a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr s a -> Maybe (Text, RecordField s a)
forall s a. Expr s a -> Maybe (Text, RecordField s a)
convert Seq (Expr s a)
keyValues =
        Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just
            (Expr s a -> Maybe (Expr s a) -> Expr s a
forall s a. Expr s a -> Maybe (Expr s a) -> Expr s a
ToMap
                (Map Text (RecordField s a) -> Expr s a
forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit ([(Text, RecordField s a)] -> Map Text (RecordField s a)
forall k v. Ord k => [(k, v)] -> Map k v
Map.fromList (Seq (Text, RecordField s a) -> [(Text, RecordField s a)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq (Text, RecordField s a)
keyValues')))
                Maybe (Expr s a)
forall a. Maybe a
Nothing
            )
  where
    convert :: Expr s a -> Maybe (Text, RecordField s a)
convert Expr s a
keyValue =
        case Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a
Core.shallowDenote Expr s a
keyValue of
            RecordLit
                (Map Text (RecordField s a) -> Map Text (RecordField s a)
forall k v. Map k v -> Map k v
Map.sort ->
                    [ ("mapKey"  , Core.shallowDenote . Core.recordFieldValue -> TextLit (Chunks [] key))
                    , ("mapValue", value)
                    ]
                ) ->
                    (Text, RecordField s a) -> Maybe (Text, RecordField s a)
forall a. a -> Maybe a
Just (Text
key, RecordField s a
value)
            Expr s a
_ ->
                Maybe (Text, RecordField s a)
forall a. Maybe a
Nothing
useToMap Expr s a
_ =
    Maybe (Expr s a)
forall a. Maybe a
Nothing