module Dhall.LSP.Backend.Dhall (
FileIdentifier,
fileIdentifierFromFilePath,
fileIdentifierFromURI,
hashNormalToCode,
WellTyped,
fromWellTyped,
Normal,
fromNormal,
Cache,
emptyCache,
invalidate,
DhallError(..),
parse,
parseWithHeader,
load,
typecheck,
normalize
) where
import Dhall.Parser (Src)
import Dhall.TypeCheck (X)
import Dhall.Core (Expr)
import qualified Dhall.Core as Dhall
import qualified Dhall.Import as Dhall
import qualified Dhall.Parser as Dhall
import qualified Dhall.TypeCheck as Dhall
import qualified Data.Graph as Graph
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Network.URI as URI
import qualified Language.Haskell.LSP.Types as LSP.Types
import qualified Data.Text as Text
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Text (Text)
import System.FilePath (splitDirectories, takeFileName, takeDirectory)
import Lens.Family (view, set)
import Control.Exception (SomeException, catch)
import Control.Monad.Trans.State.Strict (runStateT)
import Network.URI (URI)
import Data.Bifunctor (first)
newtype FileIdentifier = FileIdentifier Dhall.Chained
fileIdentifierFromFilePath :: FilePath -> FileIdentifier
fileIdentifierFromFilePath path =
let filename = Text.pack $ takeFileName path
directory = takeDirectory path
components = map Text.pack . reverse . splitDirectories $ directory
file = Dhall.File (Dhall.Directory components) filename
in FileIdentifier $ Dhall.chainedFromLocalHere Dhall.Absolute file Dhall.Code
fileIdentifierFromURI :: URI -> Maybe FileIdentifier
fileIdentifierFromURI uri
| URI.uriScheme uri == "file:" = do
path <- LSP.Types.uriToFilePath . LSP.Types.Uri . Text.pack
$ URI.uriToString id uri ""
return $ fileIdentifierFromFilePath path
fileIdentifierFromURI _ = Nothing
newtype WellTyped = WellTyped {fromWellTyped :: Expr Src X}
newtype Normal = Normal {fromNormal :: Expr Src X}
type ImportGraph = [Dhall.Depends]
data Cache = Cache ImportGraph (Map.Map Dhall.Chained Dhall.ImportSemantics)
emptyCache :: Cache
emptyCache = Cache [] Map.empty
invalidate :: FileIdentifier -> Cache -> Cache
invalidate (FileIdentifier chained) (Cache dependencies cache) =
Cache dependencies' $ Map.withoutKeys cache invalidImports
where
imports = map Dhall.parent dependencies ++ map Dhall.child dependencies
adjacencyLists = foldr
(\(Dhall.Depends parent child) -> Map.adjust (parent :) child)
(Map.fromList [ (i,[]) | i <- imports])
dependencies
(graph, importFromVertex, vertexFromImport) = Graph.graphFromEdges
[(node, node, neighbours) | (node, neighbours) <- Map.assocs adjacencyLists]
reachableImports import_ =
map (\(i,_,_) -> i) . map importFromVertex . concat $
do vertex <- vertexFromImport import_
return (Graph.reachable graph vertex)
codeImport = Dhall.chainedChangeMode Dhall.Code chained
textImport = Dhall.chainedChangeMode Dhall.RawText chained
invalidImports = Set.fromList $ codeImport : reachableImports codeImport
++ textImport : reachableImports textImport
dependencies' = filter (\(Dhall.Depends parent child) -> Set.notMember parent invalidImports
&& Set.notMember child invalidImports) dependencies
data DhallError = ErrorInternal SomeException
| ErrorImportSourced (Dhall.SourcedException Dhall.MissingImports)
| ErrorTypecheck (Dhall.TypeError Src X)
| ErrorParse Dhall.ParseError
parse :: Text -> Either DhallError (Expr Src Dhall.Import)
parse = fmap snd . parseWithHeader
parseWithHeader :: Text -> Either DhallError (Text, Expr Src Dhall.Import)
parseWithHeader = first ErrorParse . Dhall.exprAndHeaderFromText ""
load :: FileIdentifier -> Expr Src Dhall.Import -> Cache ->
IO (Either DhallError (Cache, Expr Src X))
load (FileIdentifier chained) expr (Cache graph cache) = do
let emptyStatus = Dhall.emptyStatus ""
status =
set Dhall.cache cache .
set Dhall.graph graph .
set Dhall.stack (chained :| [])
$ emptyStatus
(do (expr', status') <- runStateT (Dhall.loadWith expr) status
let cache' = view Dhall.cache status'
graph' = view Dhall.graph status'
return . Right $ (Cache graph' cache', expr'))
`catch` (\e -> return . Left $ ErrorImportSourced e)
`catch` (\e -> return . Left $ ErrorInternal e)
typecheck :: Expr Src X -> Either DhallError (WellTyped, WellTyped)
typecheck expr = case Dhall.typeOf expr of
Left err -> Left $ ErrorTypecheck err
Right typ -> Right (WellTyped expr, WellTyped typ)
normalize :: WellTyped -> Normal
normalize (WellTyped expr) = Normal $ Dhall.normalize expr
hashNormalToCode :: Normal -> Text
hashNormalToCode (Normal expr) =
Dhall.hashExpressionToCode alphaNormal
where alphaNormal = Dhall.alphaNormalize expr