From 1530a4646b5bb7ab2930d1433eda87d5f0936125 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sat, 15 Jan 2022 00:46:30 +0100 Subject: use hpack and clean up modules as annoying as yaml is, cabal's package format is somehow worse, apparently --- lib/CheckDir.hs | 2 +- lib/KindLinter.hs | 64 +++++++++++++++++++++++++++++++++++++++++++++++-------- lib/LintConfig.hs | 2 +- lib/Properties.hs | 7 +++--- lib/Types.hs | 10 ++++++++- lib/Uris.hs | 12 +++++------ lib/Util.hs | 9 +++++++- lib/WriteRepo.hs | 2 +- 8 files changed, 85 insertions(+), 23 deletions(-) (limited to 'lib') diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs index 1f69abf..f876084 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/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 f346f7f..9cde1ec 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -45,7 +45,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) @@ -344,10 +345,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 80ee014..00f86a4 100644 --- a/lib/Uris.hs +++ b/lib/Uris.hs @@ -26,8 +26,8 @@ import Network.URI.Encode as URI import Text.Regex.TDFA ((=~)) 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 diff --git a/lib/Util.hs b/lib/Util.hs index 3fe0a16..ffd9faa 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 (..)) -- cgit v1.2.3