{-# 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 Data.List.NonEmpty (NonEmpty (..))
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.Map as Map
import qualified Data.Text as Text
import qualified Dhall.Core as Core
import qualified Dhall.Map
import qualified Dhall.Optics
import qualified Lens.Family
lint :: Eq s => Expr s Import -> Expr s Import
lint :: forall s. Eq s => Expr s Import -> Expr s Import
lint = forall a b. ASetter a b a b -> (b -> Maybe a) -> a -> b
Dhall.Optics.rewriteOf forall (f :: * -> *) s a.
Applicative f =>
(Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a)
subExpressions forall {s}. Eq s => Expr s Import -> Maybe (Expr s Import)
rewrite
where
rewrite :: Expr s Import -> Maybe (Expr s Import)
rewrite Expr s Import
e =
forall s a. Expr s a -> Maybe (Expr s a)
fixAssert Expr s Import
e
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a s. Eq a => Expr s a -> Maybe (Expr s a)
removeUnusedBindings Expr s Import
e
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s. Expr s Import -> Maybe (Expr s Import)
fixParentPath Expr s Import
e
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s a. Expr s a -> Maybe (Expr s a)
removeLetInLet Expr s Import
e
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s. Expr s Import -> Maybe (Expr s Import)
addPreludeExtensions Expr s Import
e
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {s}. Eq s => Expr s Import -> Maybe (Expr s Import)
sortImports Expr s Import
e
removeUnusedBindings :: Eq a => Expr s a -> Maybe (Expr s a)
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
_)
| forall s a. Expr s a -> Bool
isOrContainsAssert Expr s a
e = 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 forall a s. Eq a => Var -> Expr s a -> Bool
`Core.freeIn` Expr s a
d) =
forall a. a -> Maybe a
Just (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
_ = forall a. Maybe a
Nothing
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@(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) =
forall a. a -> Maybe a
Just (forall s a. Binding s a -> Expr s a -> Expr s a
Let (Binding { value :: Expr s a
value = 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@(forall s a. Expr s a -> Expr s a
Core.shallowDenote -> Equivalent {})) =
forall a. a -> Maybe a
Just (forall s a. Binding s a -> Expr s a -> Expr s a
Let Binding s a
binding (forall s a. Expr s a -> Expr s a
Assert Expr s a
body))
fixAssert Expr s a
_ =
forall a. Maybe a
Nothing
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
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 <- forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [Text]
components
, forall a. NonEmpty a -> a
NonEmpty.last NonEmpty Text
nonEmpty forall a. Eq a => a -> a -> Bool
== Text
".." -> do
let newDirectory :: Directory
newDirectory =
Directory { components :: [Text]
components = 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
.. }
forall a. a -> Maybe a
Just (forall s a. a -> Expr s a
Embed Import
newImport)
ImportType
_ ->
forall a. Maybe a
Nothing
fixParentPath Expr s Import
_ = forall a. Maybe a
Nothing
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 :: 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 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 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
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{ 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
.. }
forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a. a -> Expr s a
Embed Import
newImport)
File
_ ->
forall a. Maybe a
Nothing
ImportType
_ -> do
forall a. Maybe a
Nothing
addPreludeExtensions 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 = forall s t a b. FoldLike Any s t a b -> (a -> Bool) -> s -> Bool
Lens.Family.anyOf forall (f :: * -> *) s a.
Applicative f =>
(Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a)
subExpressions forall s a. Expr s a -> Bool
isOrContainsAssert Expr s a
e
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{})) = forall a. a -> Maybe a
Just (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
_ = forall a. Maybe a
Nothing
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
(forall s a. Expr s a -> Expr s a
Core.shallowDenote -> App
(forall s a. Expr s a -> Expr s a
Core.shallowDenote -> Expr s a
List)
(forall s a. Expr s a -> Expr s a
Core.shallowDenote -> Record
(forall k v. Map k v -> Map k v
Dhall.Map.sort ->
[ (Text
"mapKey", forall s a. Expr s a -> Expr s a
Core.shallowDenote forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Expr s a
Text)
, (Text
"mapValue", RecordField s a
_)
]
)
)
)
)
[]
) =
forall a. a -> Maybe a
Just (forall s a. Expr s a -> Maybe (Expr s a) -> Expr s a
ToMap (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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq (Expr s a)
keyValues)
, Just Seq (Text, RecordField s a)
keyValues' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {s} {a}. Expr s a -> Maybe (Text, RecordField s a)
convert Seq (Expr s a)
keyValues =
forall a. a -> Maybe a
Just
(forall s a. Expr s a -> Maybe (Expr s a) -> Expr s a
ToMap
(forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit (forall k v. Ord k => [(k, v)] -> Map k v
Dhall.Map.fromList (forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq (Text, RecordField s a)
keyValues')))
forall a. Maybe a
Nothing
)
where
convert :: Expr s a -> Maybe (Text, RecordField s a)
convert Expr s a
keyValue =
case forall s a. Expr s a -> Expr s a
Core.shallowDenote Expr s a
keyValue of
RecordLit
(forall k v. Map k v -> Map k v
Dhall.Map.sort ->
[ (Text
"mapKey" , forall s a. Expr s a -> Expr s a
Core.shallowDenote forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> TextLit (Chunks [] Text
key))
, (Text
"mapValue", RecordField s a
value)
]
) ->
forall a. a -> Maybe a
Just (Text
key, RecordField s a
value)
Expr s a
_ ->
forall a. Maybe a
Nothing
useToMap Expr s a
_ =
forall a. Maybe a
Nothing
sortImports :: Eq s => Expr s Import -> Maybe (Expr s Import)
sortImports :: forall {s}. Eq s => Expr s Import -> Maybe (Expr s Import)
sortImports oldExpression :: Expr s Import
oldExpression@(Let Binding s Import
binding0 Expr s Import
oldBody0)
| Expr s Import
oldExpression forall a. Eq a => a -> a -> Bool
== Expr s Import
newExpression = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just Expr s Import
newExpression
where
toBool :: Expr s a -> Bool
toBool (Embed a
_ ) = Bool
False
toBool (Note s
_ Expr s a
e) = Expr s a -> Bool
toBool Expr s a
e
toBool Expr s a
_ = Bool
True
process :: (Map Text Int, Int)
-> Binding s a
-> Expr s a
-> (Expr s a -> Expr s a)
-> ((Int, Expr s a -> Expr s a), [(Int, Expr s a -> Expr s a)],
Expr s a)
process (Map Text Int
seen, Int
index) Binding{Maybe s
Maybe (Maybe s, Expr s a)
Text
Expr s a
value :: Expr s a
bindingSrc2 :: Maybe s
annotation :: Maybe (Maybe s, Expr s a)
bindingSrc1 :: Maybe s
variable :: Text
bindingSrc0 :: Maybe s
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
value :: forall s a. Binding s a -> Expr s a
..} Expr s a
oldBody Expr s a -> Expr s a
function = ((Int, Expr s a -> Expr s a)
pair, [(Int, Expr s a -> Expr s a)]
pairs, Expr s a
newBody)
where
order :: Int
order =
if Bool
b then Int
index else forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (Int
0 :: Int) Text
variable Map Text Int
seen
b :: Bool
b = forall s a. Expr s a -> Bool
toBool Expr s a
value
pair :: (Int, Expr s a -> Expr s a)
pair = (Int
order, Expr s a -> Expr s a
function)
~([(Int, Expr s a -> Expr s a)]
pairs, Expr s a
newBody) =
(Map Text Int, Int)
-> Expr s a -> ([(Int, Expr s a -> Expr s a)], Expr s a)
label (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
variable Int
order Map Text Int
seen, Int
index forall a. Num a => a -> a -> a
+ Int
1) Expr s a
oldBody
label :: (Map Text Int, Int)
-> Expr s a -> ([(Int, Expr s a -> Expr s a)], Expr s a)
label (Map Text Int, Int)
state (Let Binding s a
binding Expr s a
oldBody) = ((Int, Expr s a -> Expr s a)
pair forall a. a -> [a] -> [a]
: [(Int, Expr s a -> Expr s a)]
pairs, Expr s a
newBody)
where
function :: Expr s a -> Expr s a
function = forall s a. Binding s a -> Expr s a -> Expr s a
Let Binding s a
binding
~((Int, Expr s a -> Expr s a)
pair, [(Int, Expr s a -> Expr s a)]
pairs, Expr s a
newBody) = (Map Text Int, Int)
-> Binding s a
-> Expr s a
-> (Expr s a -> Expr s a)
-> ((Int, Expr s a -> Expr s a), [(Int, Expr s a -> Expr s a)],
Expr s a)
process (Map Text Int, Int)
state Binding s a
binding Expr s a
oldBody Expr s a -> Expr s a
function
label (Map Text Int, Int)
state (Note s
src (Let Binding s a
binding Expr s a
oldBody)) = ((Int, Expr s a -> Expr s a)
pair forall a. a -> [a] -> [a]
: [(Int, Expr s a -> Expr s a)]
pairs, Expr s a
newBody)
where
function :: Expr s a -> Expr s a
function Expr s a
e = forall s a. s -> Expr s a -> Expr s a
Note s
src (forall s a. Binding s a -> Expr s a -> Expr s a
Let Binding s a
binding Expr s a
e)
~((Int, Expr s a -> Expr s a)
pair, [(Int, Expr s a -> Expr s a)]
pairs, Expr s a
newBody) = (Map Text Int, Int)
-> Binding s a
-> Expr s a
-> (Expr s a -> Expr s a)
-> ((Int, Expr s a -> Expr s a), [(Int, Expr s a -> Expr s a)],
Expr s a)
process (Map Text Int, Int)
state Binding s a
binding Expr s a
oldBody Expr s a -> Expr s a
function
label (Map Text Int, Int)
_ Expr s a
body =
([], Expr s a
body)
~(NonEmpty (Int, Expr s Import -> Expr s Import)
pairs0, Expr s Import
newBody0) = ((Int, Expr s Import -> Expr s Import)
pair forall a. a -> [a] -> NonEmpty a
:| [(Int, Expr s Import -> Expr s Import)]
pairs, Expr s Import
newBody)
where
function :: Expr s Import -> Expr s Import
function = forall s a. Binding s a -> Expr s a -> Expr s a
Let Binding s Import
binding0
~((Int, Expr s Import -> Expr s Import)
pair, [(Int, Expr s Import -> Expr s Import)]
pairs, Expr s Import
newBody) =
forall {s} {a}.
(Map Text Int, Int)
-> Binding s a
-> Expr s a
-> (Expr s a -> Expr s a)
-> ((Int, Expr s a -> Expr s a), [(Int, Expr s a -> Expr s a)],
Expr s a)
process (forall k a. Map k a
Map.empty, Int
1) Binding s Import
binding0 Expr s Import
oldBody0 Expr s Import -> Expr s Import
function
sortedFunctions :: NonEmpty (Expr s Import -> Expr s Import)
sortedFunctions = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd (forall o a. Ord o => (a -> o) -> NonEmpty a -> NonEmpty a
NonEmpty.sortWith forall a b. (a, b) -> a
fst NonEmpty (Int, Expr s Import -> Expr s Import)
pairs0)
newExpression :: Expr s Import
newExpression = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. a -> a
id Expr s Import
newBody0 NonEmpty (Expr s Import -> Expr s Import)
sortedFunctions
sortImports Expr s Import
_ = forall a. Maybe a
Nothing