{-# 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
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 :: Eq s => Expr s Import -> Expr s Import
lint :: forall s. Eq s => 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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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 :: forall a s. Eq a => 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 :: forall s a. 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
bindingSrc0 :: Maybe s
variable :: Text
bindingSrc1 :: Maybe s
annotation :: Maybe (Maybe s, Expr s a)
bindingSrc2 :: Maybe s
bindingSrc0 :: forall s a. Binding s a -> Maybe s
variable :: forall s a. Binding s a -> Text
bindingSrc1 :: forall s a. Binding s a -> Maybe s
annotation :: forall s a. Binding s a -> Maybe (Maybe s, Expr s a)
bindingSrc2 :: forall s a. Binding s a -> 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 { 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
bindingSrc0 :: Maybe s
variable :: Text
bindingSrc1 :: Maybe s
annotation :: Maybe (Maybe s, Expr s a)
bindingSrc2 :: Maybe s
bindingSrc0 :: Maybe s
variable :: Text
bindingSrc1 :: Maybe s
annotation :: Maybe (Maybe s, Expr s a)
bindingSrc2 :: 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 :: forall {s}. Expr s Import -> Maybe (Expr s Import)
fixParentPath (Embed Import
oldImport) = do
    let Import{ImportHashed
ImportMode
importHashed :: ImportHashed
importMode :: ImportMode
importHashed :: Import -> ImportHashed
importMode :: Import -> ImportMode
..} = Import
oldImport

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

    case ImportType
importType of
        Local FilePrefix
Here File{ directory :: File -> Directory
directory = Directory { [Text]
components :: [Text]
components :: Directory -> [Text]
components }, Text
file :: Text
file :: 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 { 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 :: Directory
directory = Directory
newDirectory, Text
file :: Text
file :: Text
.. }

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

                let newImport :: Import
newImport = 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 :: forall {s}. Expr s Import -> Maybe (Expr s Import)
addPreludeExtensions (Embed Import
oldImport) = do
    let Import{ importHashed :: Import -> ImportHashed
importHashed = ImportHashed
oldImportHashed, ImportMode
importMode :: Import -> ImportMode
importMode :: ImportMode
.. } = Import
oldImport

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

    case ImportType
oldImportType of
        Remote URL{ path :: URL -> File
path = File
oldPath, Maybe Text
Maybe (Expr Src Import)
Text
Scheme
scheme :: Scheme
authority :: Text
query :: Maybe Text
headers :: Maybe (Expr Src Import)
scheme :: URL -> Scheme
authority :: URL -> Text
query :: URL -> Maybe Text
headers :: URL -> Maybe (Expr Src Import)
..}
            | 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 :: File -> Directory
directory :: 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{ file :: Text
file = Text
newFile, Directory
directory :: Directory
directory :: Directory
.. }

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

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

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

                            Expr s Import -> Maybe (Expr s Import)
forall a. a -> Maybe a
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 :: forall s a. 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 :: forall s a. 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 :: forall s a. 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
Dhall.Map.sort ->
                        [ (Text
"mapKey", Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a
Core.shallowDenote (Expr s a -> Expr s a)
-> (RecordField s a -> Expr s a) -> RecordField s a -> Expr s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordField s a -> Expr s a
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Expr s a
Text)
                        , (Text
"mapValue", RecordField s a
_)
                        ]
                    )
                )
            )
        )
        []
    ) =
        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 a. Seq 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Seq a -> f (Seq 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
Dhall.Map.fromList (Seq (Text, RecordField s a) -> [(Text, RecordField s a)]
forall a. Seq a -> [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
Dhall.Map.sort ->
                    [ (Text
"mapKey"  , Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a
Core.shallowDenote (Expr s a -> Expr s a)
-> (RecordField s a -> Expr s a) -> RecordField s a -> Expr s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordField s a -> Expr s a
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> TextLit (Chunks [] Text
key))
                    , (Text
"mapValue", RecordField s a
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