dhall-check (empty) → 1.0.0.0

raw patch · 4 files changed

+248/−0 lines, 4 filesdep +basedep +containersdep +dhallsetup-changed

Dependencies added: base, containers, dhall, directory, filepath, fsnotify, text, trifecta

Files

LICENSE +30/−0
Setup.hs +2/−0
dhall-check.cabal +36/−0
src/Main.hs +180/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Anton Felix Lorenzen (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Anton Felix Lorenzen nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ dhall-check.cabal view

@@ -0,0 +1,36 @@+-- This file has been generated from package.yaml by hpack version 0.17.0.+--+-- see: https://github.com/sol/hpack++name:           dhall-check+version:        1.0.0.0+synopsis:       Check all dhall files in a project+category:       Development+homepage:       https://github.com/anfelor/dhall-check#readme+bug-reports:    https://github.com/anfelor/dhall-check/issues+author:         Anton Felix Lorenzen+maintainer:     anfelor@posteo.de+copyright:      BSD3+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++source-repository head+  type: git+  location: https://github.com/anfelor/dhall-check++executable dhall-check+  main-is: Main.hs+  hs-source-dirs:+      src+  build-depends:+      base >= 4.7 && < 5+    , containers+    , directory+    , dhall+    , filepath+    , fsnotify+    , trifecta+    , text+  default-language: Haskell2010

+ src/Main.hs view

@@ -0,0 +1,180 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++import Control.Concurrent (threadDelay)+import Control.Exception hiding (TypeError)+import Control.Monad+import Data.Char+import Data.Map (Map)+import Data.Monoid+import Dhall+import Dhall.Core+import Dhall.Parser+import Dhall.Import+import Dhall.TypeCheck+import qualified Data.Map as Map+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.IO as TLIO+import System.Directory+import System.FilePath+import System.FSNotify+import Text.Trifecta.Delta (Delta(..))++import Debug.Trace+++-- | A dhall type, e.g. "entry" for "file.entry.dh"+-- Should only contain lower-case strings.+newtype DhallType = DhallType String+  deriving (Eq, Ord, Show)++-- | Turn a string into a 'DhallType'.+-- >>> dhallType "Entry"+-- DhallType "entry"+dhallType :: String -> DhallType+dhallType = DhallType . map toLower++-- | Get the 'DhallType' for a file.+-- >>> dhallTypeOf "file.entry.dh"+-- DhallType "entry"+dhallTypeOf :: FilePath -> DhallType+dhallTypeOf = DhallType . tail . map toLower . takeExtension . dropExtension+++data CheckException+  = CouldntFindTypeDefs+  | ParseException FilePath ParseError+  | UnknownType FilePath DhallType+  | TypeChecking FilePath (TypeError Src)+  deriving (Show)++instance Exception CheckException where+  displayException CouldntFindTypeDefs =+    "Error: Expected a .dhall file with type definitions, but couldn't find it."+  displayException (UnknownType f (DhallType t)) =+    "Error: The file " ++ f ++ "has an unknown type: " ++ t+  displayException (ParseException f pe) =+    "While parsing " ++ f ++ ":" ++ displayException pe+  displayException (TypeChecking f te) =+    "While type checking " ++ f ++ ":" ++ displayException te+++main :: IO ()+main = do+  here <- getCurrentDirectory+  printExceptions $ do+    typedefs <- allTypeDefs here+    dhallfiles <- allDhallFiles here+    -- Check all files once+    printExceptions $ do+      checkAll typedefs dhallfiles+      putStrLn "No errors."+    -- and then watch for changes+    withManager $ \mgr -> do+      watchTree mgr here isDhallFile $ \event -> do+        case event of+          Added f utc -> do+            putStrLn $ "\nAdded: " ++ f+            printExceptions $ do+              expr <- loadFile f+              checkFile typedefs (f, expr)+              putStrLn "No errors."+          Modified f utc -> do+            putStrLn $ "\nModified: " ++ f+            printExceptions $ do+              expr <- loadFile f+              checkFile typedefs (f, expr)+              putStrLn "No errors."+          Removed f utc -> pure ()+      forever $ threadDelay 1000000+  where+    -- | Print 'CheckException's and recover.+    printExceptions comp = do+      result <- try comp+      case result of+        Left e -> putStrLn $ displayException (e :: CheckException)+        Right v -> pure v++    isDhallFile f = (flip elem [".dhall", ".dh"] . takeExtension . eventPath) f+                 && (not . (==) '.' . head . takeFileName . eventPath) f+++-- | A list of all files in a directory with the one of the given extensions,+-- using absolute paths.+--+-- >>> allFiles "/home/user" [".hs"]+-- ["/home/user/project/Main.hs", ...]+allFiles :: Foldable t => FilePath -> t String -> IO [FilePath]+allFiles dir exts = do+  setCurrentDirectory dir+  files <- mapM makeAbsolute =<< listDirectory dir+  inThisDir <- flip filterM files $ \f -> do+    exists <- doesFileExist f+    let valid = takeExtension f `elem` exts+    pure $ exists && valid+  subdirs <- filterM doesDirectoryExist files+  inSubDirs <- forM subdirs $ \d -> do+    allFiles (dir </> d) exts+  pure $ inThisDir ++ concat inSubDirs+++-- | Get all type definitions in the ".dhall" directory of a given directory+-- and return them in a map of filename without ".dht" -> expression in file.+allTypeDefs :: FilePath -> IO (Map DhallType (Expr Src X))+allTypeDefs dir = do+  isThere <- doesDirectoryExist (dir </> ".dhall")+  when (not isThere) $ do+    throwIO CouldntFindTypeDefs+  files <- allFiles (dir </> ".dhall") [".dht"]+  exprs <- forM files $ \f -> do+    let name = dhallType $ takeFileName $ dropExtension f+    sequence (name, loadFile f)+  pure $ Map.fromList exprs+++-- | Get all a list of all dhall files in the given directory using absolute paths.+allDhallFiles :: FilePath -> IO [(FilePath, Expr Src X)]+allDhallFiles dir = do+  files <- allFiles dir [".dh", ".dhall"]+  forM files $ \f -> do+    sequence (f, loadFile f)+++-- | Compile a dhall file.+loadFile :: FilePath -> IO (Expr Src X)+loadFile f = do+  let delta = Directed "(input)" 0 0 0 0+  content <- TLIO.readFile f+  case exprFromText delta content of+    Left e -> throwIO $ ParseException f e+    Right e -> load e+++-- | Typecheck a single file against one of the given types.+-- Throws an exception on failure to do so.+--+-- >>> checkFile (Map.fromList [("conf", .. )]) ("file.conf.dh", ..)+-- /throws/ TypeChecking "file.conf.dh" (TypeError ..)+checkFile :: Map DhallType (Expr Src X) -> (FilePath, Expr Src X) -> IO ()+checkFile types (f, expr) = do+  let name = dhallTypeOf f+  case Map.lookup name types of+    Nothing -> do+      throwIO $ UnknownType f name+    Just t -> do+      let annot = case (expr, t) of+            (Note (Src begin1 end1 bytes1) _, Note (Src begin2 end2 bytes2) _) ->+              Note (Src begin1 end1 bytes') (Annot expr t)+              where+                bytes' = bytes1 <> "\n\n : \n\n" <> bytes2+            _ -> Annot expr t+      case typeOf annot of+        Left err -> throwIO $ TypeChecking f err+        Right _ -> pure ()+++-- | Perform 'checkFile' on every file in the Foldable.+checkAll :: Foldable t => Map DhallType (Expr Src X) -> t (FilePath, Expr Src X) -> IO ()+checkAll types = mapM_ (checkFile types)