{-# 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
    , removeLetInLet
    , replaceOptionalBuildFold
    , replaceSaturatedOptionalFold
    ) where

import Control.Applicative ((<|>))

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

import qualified Data.List.NonEmpty as NonEmpty
import qualified Dhall.Core         as Core
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@
    * Replaces deprecated @Optional\/fold@ and @Optional\/build@ built-ins
-}
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)
lowerPriorityRewrite
    (Expr s Import -> Expr s Import)
-> (Expr s Import -> Expr s Import)
-> Expr s Import
-> Expr s Import
forall b c a. (b -> c) -> (a -> b) -> a -> c
.   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 a. Expr s a -> Maybe (Expr s a)
higherPriorityRewrite
  where
    lowerPriorityRewrite :: Expr s Import -> Maybe (Expr s Import)
lowerPriorityRewrite e :: 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 a. Expr s a -> Maybe (Expr s a)
replaceOptionalBuildFold Expr s Import
e

    higherPriorityRewrite :: Expr s a -> Maybe (Expr s a)
higherPriorityRewrite = Expr s a -> Maybe (Expr s a)
forall s a. Expr s a -> Maybe (Expr s a)
replaceSaturatedOptionalFold

-- | 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 _ _ _ _ _ e :: Expr s a
e) _)
    | 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 _ a :: Text
a _ _ _ _) d :: Expr s a
d)
    | Bool -> Bool
not (Text -> Int -> Var
V Text
a 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 (-1) (Text -> Int -> Var
V Text
a 0) Expr s a
d)
removeUnusedBindings _ = 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 {}), ..}) body :: 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, .. }) Expr s a
body)
fixAssert (Let binding :: 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 _ =
    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 oldImport :: Import
oldImport) = do
    let Import{..} = Import
oldImport

    let ImportHashed{..} = ImportHashed
importHashed

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

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

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

                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)
        _ ->
            Maybe (Expr s Import)
forall a. Maybe a
Nothing
fixParentPath _  = Maybe (Expr s Import)
forall a. Maybe a
Nothing

isOrContainsAssert :: Expr s a -> Bool
isOrContainsAssert :: Expr s a -> Bool
isOrContainsAssert (Assert _) = Bool
True
isOrContainsAssert e :: 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 :: Binding s a
binding (Note _ 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 _ = Maybe (Expr s a)
forall a. Maybe a
Nothing

-- | This replaces @Optional/fold@ and @Optional/build@, both of which can be
-- implemented within the language
replaceOptionalBuildFold :: Expr s a -> Maybe (Expr s a)
replaceOptionalBuildFold :: Expr s a -> Maybe (Expr s a)
replaceOptionalBuildFold OptionalBuild =
    Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just
        (Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
Lam "a" (Const -> Expr s a
forall s a. Const -> Expr s a
Const Const
Type)
            (Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
Lam "build"
                (Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
Pi "optional" (Const -> Expr s a
forall s a. Const -> Expr s a
Const Const
Type)
                    (Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
Pi "some" (Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
Pi "_" "a" "optional")
                        (Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
Pi "none" "optional" "optional")
                    )
                )
                (Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
App (Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
App (Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
App "build" (Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
App Expr s a
forall s a. Expr s a
Optional "a")) (Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
Lam "x" "a" (Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a
Some "x"))) (Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
App Expr s a
forall s a. Expr s a
None "a"))
            )
        )
replaceOptionalBuildFold OptionalFold =
    Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just
        (Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
Lam "a" (Const -> Expr s a
forall s a. Const -> Expr s a
Const Const
Type)
            (Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
Lam "o" (Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
App Expr s a
forall s a. Expr s a
Optional "a")
                (Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
Lam "optional" (Const -> Expr s a
forall s a. Const -> Expr s a
Const Const
Type)
                    (Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
Lam "some" (Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
Pi "_" "a" "optional")
                        (Text -> Expr s a -> Expr s a -> Expr s a
forall s a. Text -> Expr s a -> Expr s a -> Expr s a
Lam "none" "optional"
                            (Expr s a -> Expr s a -> Maybe (Expr s a) -> Expr s a
forall s a. Expr s a -> Expr s a -> Maybe (Expr s a) -> Expr s a
Merge
                                (Map Text (Expr s a) -> Expr s a
forall s a. Map Text (Expr s a) -> Expr s a
RecordLit
                                    [ ("Some", "some")
                                    , ("None", "none")
                                    ]
                                )
                                "o"
                                Maybe (Expr s a)
forall a. Maybe a
Nothing
                            )
                        )
                    )
                )
            )
        )
replaceOptionalBuildFold _ =
    Maybe (Expr s a)
forall a. Maybe a
Nothing

-- | This replaces a saturated @Optional/fold@ with the equivalent @merge@
-- expression
replaceSaturatedOptionalFold :: Expr s a -> Maybe (Expr s a)
replaceSaturatedOptionalFold :: Expr s a -> Maybe (Expr s a)
replaceSaturatedOptionalFold
    (App
        (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 -> App
                (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 -> App
                        (Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a
Core.shallowDenote -> Expr s a
OptionalFold)
                        _
                    )
                    o :: Expr s a
o
                )
                _
            )
            some :: Expr s a
some
        )
        none :: Expr s a
none
    ) = Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just (Expr s a -> Expr s a -> Maybe (Expr s a) -> Expr s a
forall s a. Expr s a -> Expr s a -> Maybe (Expr s a) -> Expr s a
Merge (Map Text (Expr s a) -> Expr s a
forall s a. Map Text (Expr s a) -> Expr s a
RecordLit [ ("Some", Expr s a
some), ("None", Expr s a
none) ]) Expr s a
o Maybe (Expr s a)
forall a. Maybe a
Nothing)
replaceSaturatedOptionalFold _ =
    Maybe (Expr s a)
forall a. Maybe a
Nothing