diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | lib/CheckDir.hs | 2 | ||||
| -rw-r--r-- | lib/CheckMap.hs | 9 | ||||
| -rw-r--r-- | lib/KindLinter.hs | 64 | ||||
| -rw-r--r-- | lib/LintConfig.hs | 2 | ||||
| -rw-r--r-- | lib/Properties.hs | 9 | ||||
| -rw-r--r-- | lib/Types.hs | 10 | ||||
| -rw-r--r-- | lib/Uris.hs | 18 | ||||
| -rw-r--r-- | lib/Util.hs | 9 | ||||
| -rw-r--r-- | lib/WriteRepo.hs | 2 | ||||
| -rw-r--r-- | package.yaml | 52 | ||||
| -rw-r--r-- | src/Main.hs | 10 | ||||
| -rw-r--r-- | stack.yaml | 46 | ||||
| -rw-r--r-- | walint.cabal | 150 |
14 files changed, 228 insertions, 156 deletions
@@ -1,2 +1,3 @@ dist-newstyle/* .stack-work +walint.cabal diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs index 59c6f2f..02985ec 100644 --- a/lib/CheckDir.hs +++ b/lib/CheckDir.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeFamilies #-} -- | Module that contains high-level checking for an entire directory -module CheckDir (recursiveCheckDir, DirResult(..), resultIsFatal) where +module CheckDir (recursiveCheckDir, DirResult(..), resultIsFatal) where import CheckMap (MapResult (..), loadAndLintMap) import Control.Monad (void) diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index 2677a30..cfa4b6e 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -27,14 +27,15 @@ import LintWriter (LintResult, invertLintResult, resultToDeps, resultToLints, resultToOffers, runLintWriter) import Properties (checkLayer, checkMap, checkTileset) +import System.FilePath (takeFileName) import Tiled (Layer (layerLayers, layerName), LoadResult (..), Tiledmap (tiledmapLayers, tiledmapTilesets), loadTiledmap) -import Types (Dep (MapLink), Hint (Hint, hintLevel, hintMsg), - Level (..), lintsToHints) +import Types (Dep (MapLink), + Hint (Hint, hintLevel, hintMsg), Level (..), + lintsToHints) import Util (PrettyPrint (prettyprint), prettyprint) -import System.FilePath (takeFileName) @@ -106,7 +107,7 @@ runLinter isMain config tiledmap depth = MapResult where linksLobby = \case MapLink link -> "/@/rc3_21/lobby" `T.isPrefixOf` link - _ -> False + _ -> False layerDeps = concatMap resultToDeps layer layer = checkLayerRec config depth (V.toList $ tiledmapLayers tiledmap) tileset = checkThing tiledmapTilesets checkTileset diff --git a/lib/KindLinter.hs b/lib/KindLinter.hs index 4ecf067..ccca1db 100644 --- a/lib/KindLinter.hs +++ b/lib/KindLinter.hs @@ -1,14 +1,23 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module KindLinter where -import Data.Map.Strict -import Data.HList -import GHC.TypeLits (Symbol, KnownSymbol) +import Data.HList +import Data.Kind (Type) +import Data.Map.Strict +import Data.Void (Void) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) func :: a -> HList [Int, String] @@ -17,12 +26,49 @@ func _ = hBuild 10 "test" field :: forall a. KnownSymbol a => Label a field = Label +data Linter a = Some a | None +type LintSingleton b a = Tagged b a + +-- newtype LintSet a :: Record '[LintSingleton Int] +-- newtype LintSet (a :: Type -> Record '[Type]) = Record (a Void) + +type SomeList (a :: Type) = Record '[Tagged "test" a] + +type family MkList (b :: [Symbol]) a where + MkList '[] _ = '[] + MkList (x:xs) a = Tagged x a : MkList xs a + +type Lints labels a = Record (MkList labels a) + +type KnownProperties = '["hello", "test"] + +record :: Lints KnownProperties Int record = + Label @"hello" .=. 20 .*. Label @"test" .=. 10 .*. - field @"x" .=. 20 .*. + -- field @"x" .=. 20 .*. emptyRecord + +class KnownList a where + listVal :: Proxy a -> [String] + +instance KnownList '[] where + listVal _ = [] + +instance (KnownList xs, KnownSymbol x) => KnownList (x:xs) where + listVal _ = symbolVal (Proxy @x) : listVal (Proxy @xs) + + +lints :: [String] +lints = listVal (Proxy @KnownProperties) + +-- TODO: how to pattern match on that? +doSth :: forall a b ctxt. (KnownList a, b ~ MkList a (Linter ctxt)) => Proxy b -> String -> Linter ctxt +doSth _ name = None -- want to get a different result for each value of name in a + -- is there a better way than using listVal / something related to it? + -- TODO: these should be limited to Tagged "symbol" (LintWriter a) tileLints = field @"test" .=. (\a -> a) .*. diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs index 904d930..e71638b 100644 --- a/lib/LintConfig.hs +++ b/lib/LintConfig.hs @@ -10,7 +10,7 @@ {-# LANGUAGE UndecidableInstances #-} -- | Module that deals with handling config options -module LintConfig where +module LintConfig (LintConfig(..), LintConfig', patchConfig) where import Control.Monad.Identity (Identity) import Data.Aeson (FromJSON (parseJSON), Options (..), diff --git a/lib/Properties.hs b/lib/Properties.hs index 00d03da..87b2a28 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -12,7 +12,7 @@ module Properties (checkMap, checkTileset, checkLayer) where import Control.Monad (forM, forM_, unless, when) -import Data.Text (Text, intercalate, isPrefixOf, isInfixOf) +import Data.Text (Text, intercalate, isInfixOf, isPrefixOf) import qualified Data.Text as T import qualified Data.Vector as V import Tiled (Layer (..), Object (..), Property (..), @@ -44,7 +44,8 @@ import LintWriter (LintWriter, adjust, askContext, import Paths (PathResult (..), RelPath (..), getExtension, isOldStyle, parsePath) import Types (Dep (Link, Local, LocalMap, MapLink)) -import Uris (SubstError (..), applySubsts, parseUri, extractDomain) +import Uris (SubstError (..), applySubsts, extractDomain, + parseUri) @@ -338,10 +339,10 @@ checkObjectGroupProperty (Property name _) = case name of \not the object layer." _ -> warn $ "unknown property " <> prettyprint name <> " for objectgroup layers" -checkIsRc3Url :: Text -> Bool +checkIsRc3Url :: Text -> Bool checkIsRc3Url text= case extractDomain text of Nothing -> False - Just domain -> do + Just domain -> do domain == "https://static.rc3.world" diff --git a/lib/Types.hs b/lib/Types.hs index 3ec9ebc..588c8ea 100644 --- a/lib/Types.hs +++ b/lib/Types.hs @@ -7,7 +7,15 @@ -- | basic types for the linter to eat and produce -- The dark magic making thse useful is in LintWriter -module Types where +module Types + ( Level(..) + , Lint(..) + , Dep(..) + , Hint(..) + , hint + , lintLevel + , lintsToHints + ) where import Control.Monad.Trans.Maybe () import Data.Aeson (FromJSON, ToJSON (toJSON), diff --git a/lib/Uris.hs b/lib/Uris.hs index 22b36eb..00f86a4 100644 --- a/lib/Uris.hs +++ b/lib/Uris.hs @@ -22,12 +22,12 @@ import Data.Text (Text, pack, unpack) import qualified Data.Text as T import GHC.Generics (Generic) import GHC.TypeLits (KnownSymbol, symbolVal) +import Network.URI.Encode as URI import Text.Regex.TDFA ((=~)) -import Witherable (mapMaybe) -import Network.URI.Encode as URI +import Witherable (mapMaybe) -import Network.URI as NativeUri -import Data.String +import Data.String +import Network.URI as NativeUri data Substitution = Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] } @@ -48,7 +48,7 @@ type SchemaSet = [(Text, Substitution)] extractDomain :: Text -> Maybe Text extractDomain url = case parseUri url of - Nothing -> Nothing + Nothing -> Nothing Just (_,domain,_) -> Just domain @@ -60,13 +60,13 @@ parseUri uri = Nothing -> Nothing Just parsedUri -> case uriAuthority parsedUri of Nothing -> Nothing - -- https: + -- https: Just uriAuth -> Just (T.replace (fromString ":") (fromString "") (fromString (uriScheme parsedUri )), - -- //anonymous@ www.haskell.org :42 + -- //anonymous@ www.haskell.org :42 fromString(uriUserInfo uriAuth++uriRegName uriAuth ++ uriPort uriAuth), -- /ghc ?query #frag fromString(uriPath parsedUri ++ uriQuery parsedUri ++ uriFragment parsedUri)) - + data SubstError = SchemaDoesNotExist Text @@ -94,7 +94,7 @@ applySubsts s substs uri = do [] -> Left (SchemaDoesNotExist schema) results@(_:_) -> case mapMaybe rightToMaybe results of suc:_ -> Right suc - _ -> minimum results + _ -> minimum results where note = maybeToRight diff --git a/lib/Util.hs b/lib/Util.hs index a6c8354..21a2661 100644 --- a/lib/Util.hs +++ b/lib/Util.hs @@ -4,7 +4,14 @@ -- | has (perhaps inevitably) morphed into a module that mostly -- concerns itself with wrangling haskell's string types -module Util where +module Util + ( mkProxy + , showText + , PrettyPrint(..) + , printPretty + , naiveEscapeHTML + , layerIsEmpty + ) where import Data.Aeson as Aeson import Data.Proxy (Proxy (..)) diff --git a/lib/WriteRepo.hs b/lib/WriteRepo.hs index c1a3f78..36c0df7 100644 --- a/lib/WriteRepo.hs +++ b/lib/WriteRepo.hs @@ -3,7 +3,7 @@ -- | Module for writing an already linted map Repository back out again. -module WriteRepo where +module WriteRepo (writeAdjustedRepository) where import CheckDir (DirResult (..), resultIsFatal) import CheckMap (MapResult (..)) diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..b3684cd --- /dev/null +++ b/package.yaml @@ -0,0 +1,52 @@ +name: walint +version: 0.1 +homepage: https://stuebinm.eu/git/walint +# TODO: license +author: stuebinm +maintainer: stuebinm@disroot.org +copyright: 2022 stuebinm +ghc-options: -Wall -Wno-name-shadowing + +dependencies: + - base + - aeson + - bytestring + - mtl + - text + +library: + source-dirs: 'lib' + dependencies: + - containers + - text + - vector + - transformers + - either + - filepath + - getopt-generics + - regex-tdfa + - extra + - witherable + - dotgen + - text-metrics + - uri-encode + - network-uri + - HList + exposed-modules: + - CheckDir + - WriteRepo + - Util + - Types + - LintConfig + +executables: + walint: + main: Main.hs + source-dirs: 'src' + build-tools: hspec-discover + dependencies: + - walint + - getopt-generics + - aeson-pretty + - template-haskell + - process diff --git a/src/Main.hs b/src/Main.hs index 9bc09ff..beee091 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -6,7 +6,7 @@ module Main where -import Control.Monad (unless) +import Control.Monad (unless, when) import Control.Monad.Identity (Identity) import Data.Aeson (eitherDecode, encode) import Data.Aeson.Encode.Pretty (encodePretty) @@ -16,17 +16,17 @@ import Data.Maybe (fromMaybe) import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import System.Exit (ExitCode (..), exitWith) -import WithCli +import System.IO (hPutStrLn, stderr) +import WithCli (Generic, HasArguments, withCli) import CheckDir (recursiveCheckDir, resultIsFatal) -import Control.Monad (when) import LintConfig (LintConfig (..), patchConfig) -import System.IO (hPutStrLn, stderr) import Types (Level (..)) import Util (printPretty) -import qualified Version as V (version) import WriteRepo (writeAdjustedRepository) +import qualified Version as V (version) + -- | the options this cli tool can take data Options = Options { repository :: Maybe String @@ -1,22 +1,3 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml resolver: url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/16.yaml @@ -44,34 +25,9 @@ extra-deps: - HList-0.5.1.0@sha256:3ecb2d10ad2b3d36ad28e2f08505f9c3d7143ca737ef13b3e64db503635966c2,7525 allow-newer: true -# - acme-missiles-0.3 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# -# extra-deps: [] -# Override default flag values for local packages and extra-deps +# use aeson with a non-hash-floodable implementation flags: aeson: ordered-keymap: true -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=2.7" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/walint.cabal b/walint.cabal index fd8db2f..34737d3 100644 --- a/walint.cabal +++ b/walint.cabal @@ -1,81 +1,81 @@ -cabal-version: 2.4 -name: walint -version: 0.1.0.0 +cabal-version: 1.12 --- A short (one-line) description of the package. --- synopsis: +-- This file has been generated from package.yaml by hpack version 0.34.5. +-- +-- see: https://github.com/sol/hpack --- A longer description of the package. --- description: - --- A URL where users can report bugs. --- bug-reports: - --- The license under which the package is released. --- license: -author: stuebinm -maintainer: stuebinm@disroot.org - --- A copyright notice. --- copyright: --- category: -extra-source-files: CHANGELOG.md +name: walint +version: 0.1 +homepage: https://stuebinm.eu/git/walint +author: stuebinm +maintainer: stuebinm@disroot.org +copyright: 2022 stuebinm +build-type: Simple library - default-language: Haskell2010 - ghc-options: -Wall -Wno-name-shadowing - hs-source-dirs: lib - exposed-modules: - CheckMap - WriteRepo - CheckDir - LintWriter - Properties - Tiled - TiledAbstract - Util - Types - Paths - Uris - LintConfig - Badges - LayerData - Dirgraph - KindLinter - build-depends: base, - aeson, - bytestring, - containers, - text, - vector, - transformers, - mtl, - either, - filepath, - getopt-generics, - regex-tdfa, - extra, - witherable, - dotgen, - text-metrics, - uri-encode, - network-uri, - HList + exposed-modules: + CheckDir + WriteRepo + Util + Types + LintConfig + other-modules: + Badges + CheckMap + Dirgraph + KindLinter + LayerData + LintWriter + Paths + Properties + Tiled + TiledAbstract + Uris + Paths_walint + hs-source-dirs: + lib + ghc-options: -Wall -Wno-name-shadowing + build-depends: + HList + , aeson + , base + , bytestring + , containers + , dotgen + , either + , extra + , filepath + , getopt-generics + , mtl + , network-uri + , regex-tdfa + , text + , text-metrics + , transformers + , uri-encode + , vector + , witherable + default-language: Haskell2010 --- TODO: move more stuff into lib, these dependencies are silly executable walint - main-is: Main.hs - ghc-options: -Wall - build-depends: base, - walint, - getopt-generics, - aeson, - aeson-pretty, - bytestring, - mtl, - text, - template-haskell, - process - hs-source-dirs: src - default-language: Haskell2010 - other-modules: Version + main-is: Main.hs + other-modules: + Version + Paths_walint + hs-source-dirs: + src + ghc-options: -Wall -Wno-name-shadowing + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + aeson + , aeson-pretty + , base + , bytestring + , getopt-generics + , mtl + , process + , template-haskell + , text + , walint + default-language: Haskell2010 |