{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Dhall.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
lint :: Expr s Import -> Expr s Import
lint = Dhall.Optics.rewriteOf subExpressions rewrite
where
rewrite e =
fixAssert e
<|> removeUnusedBindings e
<|> fixParentPath e
<|> removeLetInLet e
<|> addPreludeExtensions e
removeUnusedBindings :: Eq a => Expr s a -> Maybe (Expr s a)
removeUnusedBindings (Let (Binding _ _ _ _ _ e) _)
| isOrContainsAssert e = Nothing
removeUnusedBindings (Let (Binding _ a _ _ _ _) d)
| not (V a 0 `Core.freeIn` d) =
Just (Core.shift (-1) (V a 0) d)
removeUnusedBindings _ = Nothing
fixAssert :: Expr s a -> Maybe (Expr s a)
fixAssert (Let (Binding { value = v@(Core.shallowDenote -> Equivalent {}), ..}) body) =
Just (Let (Binding { value = Assert v, .. }) body)
fixAssert (Let binding body@(Core.shallowDenote -> Equivalent {})) =
Just (Let binding (Assert body))
fixAssert _ =
Nothing
fixParentPath :: Expr s Import -> Maybe (Expr s Import)
fixParentPath (Embed oldImport) = do
let Import{..} = oldImport
let ImportHashed{..} = importHashed
case importType of
Local Here File{ directory = Directory { components }, .. }
| Just nonEmpty <- NonEmpty.nonEmpty components
, NonEmpty.last nonEmpty == ".." -> do
let newDirectory =
Directory { components = NonEmpty.init nonEmpty }
let newImportType =
Local Parent File{ directory = newDirectory, .. }
let newImportHashed =
ImportHashed { importType = newImportType, .. }
let newImport = Import { importHashed = newImportHashed, .. }
Just (Embed newImport)
_ ->
Nothing
fixParentPath _ = Nothing
addPreludeExtensions :: Expr s Import -> Maybe (Expr s Import)
addPreludeExtensions (Embed oldImport) = do
let Import{ importHashed = oldImportHashed, .. } = oldImport
let ImportHashed{ importType = oldImportType, .. } = oldImportHashed
case oldImportType of
Remote URL{ path = oldPath, ..}
| authority == "prelude.dhall-lang.org" ->
case oldPath of
File{ file = oldFile, .. }
| not (Text.isSuffixOf ".dhall" oldFile) -> do
let newFile = oldFile <> ".dhall"
let newPath = File{ file = newFile, .. }
let newImportType = Remote URL{ path = newPath, .. }
let newImportHashed =
ImportHashed{ importType = newImportType, .. }
let newImport =
Import{ importHashed = newImportHashed, .. }
return (Embed newImport)
_ ->
Nothing
_ -> do
Nothing
addPreludeExtensions _ = Nothing
isOrContainsAssert :: Expr s a -> Bool
isOrContainsAssert (Assert _) = True
isOrContainsAssert e = Lens.Family.anyOf subExpressions isOrContainsAssert e
removeLetInLet :: Expr s a -> Maybe (Expr s a)
removeLetInLet (Let binding (Note _ l@Let{})) = Just (Let binding l)
removeLetInLet _ = Nothing
useToMap :: Expr s a -> Maybe (Expr s a)
useToMap
(ListLit
t@(Just
(Core.shallowDenote -> App
(Core.shallowDenote -> List)
(Core.shallowDenote -> Record
(Map.sort ->
[ ("mapKey", Core.shallowDenote . Core.recordFieldValue -> Text)
, ("mapValue", _)
]
)
)
)
)
[]
) =
Just (ToMap (RecordLit []) t)
useToMap (ListLit _ keyValues)
| not (null keyValues)
, Just keyValues' <- traverse convert keyValues =
Just
(ToMap
(RecordLit (Map.fromList (Foldable.toList keyValues')))
Nothing
)
where
convert keyValue =
case Core.shallowDenote keyValue of
RecordLit
(Map.sort ->
[ ("mapKey" , Core.shallowDenote . Core.recordFieldValue -> TextLit (Chunks [] key))
, ("mapValue", value)
]
) ->
Just (key, value)
_ ->
Nothing
useToMap _ =
Nothing