diff --git a/guide.cabal b/guide.cabal index da88729..17a5958 100644 --- a/guide.cabal +++ b/guide.cabal @@ -11,7 +11,7 @@ author: Artyom maintainer: yom@artyom.me -- copyright: category: Web -tested-with: GHC == 7.10.3 +tested-with: GHC == 8.0.1 build-type: Simple extra-source-files: CHANGELOG.md @@ -58,8 +58,8 @@ library , Spock-lucid == 0.3.* , acid-state == 0.14.* , aeson == 0.11.* - , aeson-pretty == 0.7.* - , base >=4.8 && <4.9 + , aeson-pretty + , base >=4.9 && <4.10 , base-prelude , bytestring , cereal @@ -95,6 +95,7 @@ library , patches-vector , path-pieces , random >= 1.1 + , reroute , safecopy , semigroups , shortcut-links >= 0.4.2 @@ -147,14 +148,14 @@ test-suite tests , guide , hspec < 3 , hspec-expectations - , hspec-webdriver < 1.2 + , hspec-webdriver < 1.3 , lucid < 3 , microlens-platform < 0.4 , monad-loops < 0.5 , network-uri , quickcheck-text < 0.2 , slave-thread - , tagsoup < 0.14 + , tagsoup < 1 , text-all < 0.4 , transformers , webdriver >= 0.8.4 && < 0.9 diff --git a/lib/Guide.hs b/lib/Guide.hs index a1982dc..3abb52d 100644 --- a/lib/Guide.hs +++ b/lib/Guide.hs @@ -37,6 +37,8 @@ import Data.IP (IP) -- Web import Web.Spock hiding (head, get, text) import qualified Web.Spock as Spock +import Web.Spock.Config +import Web.Routing.Combinators (PathState(..)) import Web.Spock.Lucid import Lucid hiding (for_) import Network.Wai.Middleware.Static (staticPolicy, addBase) @@ -149,13 +151,13 @@ getConfig :: (Monad m, HasSpock m, SpockState m ~ ServerState) => m Config getConfig = _config <$> Spock.getState -itemVar :: Path '[Uid Item] +itemVar :: Path '[Uid Item] 'Open itemVar = "item" var -categoryVar :: Path '[Uid Category] +categoryVar :: Path '[Uid Category] 'Open categoryVar = "category" var -traitVar :: Path '[Uid Trait] +traitVar :: Path '[Uid Trait] 'Open traitVar = "trait" var invalidateCache' @@ -826,8 +828,10 @@ mainWith config = do let serverState = ServerState { _config = config, _db = db } - let spockConfig = (defaultSpockCfg () PCNoDatabase serverState) { - spc_maxRequestSize = Just (1024*1024) } + spockConfig <- do + cfg <- defaultSpockCfg () PCNoDatabase serverState + return cfg { + spc_maxRequestSize = Just (1024*1024) } when (_prerender config) $ do putStr "Prerendering pages to be cached... " globalState <- liftIO $ Acid.query db GetGlobalState diff --git a/lib/Utils.hs b/lib/Utils.hs index db023d3..014a9ea 100644 --- a/lib/Utils.hs +++ b/lib/Utils.hs @@ -50,6 +50,7 @@ module Utils -- * Template Haskell hs, dumpSplices, + bangNotStrict, -- * Safecopy Change(..), @@ -240,6 +241,9 @@ dumpSplices x = do mapM_ (reportWarning . pprint) ds return ds +bangNotStrict :: Q Bang +bangNotStrict = bang noSourceUnpackedness noSourceStrictness + {- | A change from one version of a record (one constructor, several fields) to another version. We only record the latest version, so we have to be able to @@ -352,7 +356,7 @@ changelog bareTyName (newVer, Past oldVer) changes = do -- First, 'reify' it. See documentation for 'reify' to understand why we -- use 'lookupValueName' here (if we just do @reify newTyName@, we might -- get the constructor instead). - TyConI (DataD _cxt _name _vars cons _deriving) <- do + TyConI (DataD _cxt _name _vars _kind cons _deriving) <- do mbReallyTyName <- lookupTypeName (nameBase newTyName) case mbReallyTyName of Just reallyTyName -> reify reallyTyName @@ -363,6 +367,8 @@ changelog bareTyName (newVer, Past oldVer) changes = do fail "changelog: can't yet work with types with context" unless (null _vars) $ fail "changelog: can't yet work with types with variables" + unless (isNothing _kind) $ + fail "changelog: can't yet work with types with kinds" -- We assume that the type is a single-constructor record. con <- case cons of [x] -> return x @@ -371,14 +377,13 @@ changelog bareTyName (newVer, Past oldVer) changes = do -- Check that the type is actually a record and that there are no strict -- fields (which we cannot handle yet); when done, make a list of fields -- that is easier to work with. We strip names to their bare form. + let normalBang = Bang NoSourceUnpackedness NoSourceStrictness (recName :: String, fields :: [(String, Type)]) <- case con of RecC cn fs - | all (== NotStrict) (fs^..each._2) -> + | all (== normalBang) (fs^..each._2) -> return (mkBare cn, [(mkBare n, t) | (n,_,t) <- fs]) | otherwise -> fail "changelog: can't work with strict/unpacked fields" _ -> fail "changelog: the type must be a record" - -- This will only be needed on newer GHC: - -- let normalBang = Bang NoSourceUnpackedness NoSourceStrictness -- Check that all 'Added' fields are actually present in the new type -- and that all 'Removed' fields aren't there for_ (M.keys added) $ \n -> do @@ -406,16 +411,17 @@ changelog bareTyName (newVer, Past oldVer) changes = do -- Then we construct the record constructor: -- FooRec_v3 { a_v3 :: String, b_v3 :: Bool } let oldRec = recC (mkOld recName) - [varStrictType (mkOld fName) - (strictType notStrict fType) + [varBangType (mkOld fName) + (bangType bangNotStrict fType) | (fName, fType) <- M.toList oldFields] -- And the data type: -- data Foo_v3 = FooRec_v3 {...} let oldTypeDecl = dataD (cxt []) -- no context oldTyName -- name of old type [] -- no variables + Nothing -- no explicit kind [oldRec] -- one constructor - [] -- not deriving anything + (cxt []) -- not deriving anything -- Next we generate the migration instance. It has two inner declarations. -- First declaration – “type MigrateFrom Foo = Foo_v3”: @@ -459,12 +465,14 @@ data GenConstructor = Copy Name | Custom String [(String, Name)] genVer :: Name -> Int -> [GenConstructor] -> Q [Dec] genVer tyName ver constructors = do -- Get information about the new version of the datatype - TyConI (DataD _cxt _name _vars cons _deriving) <- reify tyName + TyConI (DataD _cxt _name _vars _kind cons _deriving) <- reify tyName -- Let's do some checks first unless (null _cxt) $ fail "genVer: can't yet work with types with context" unless (null _vars) $ fail "genVer: can't yet work with types with variables" + unless (isNothing _kind) $ + fail "genVer: can't yet work with types with kinds" let oldName n = mkName (nameBase n ++ "_v" ++ show ver) @@ -479,8 +487,8 @@ genVer tyName ver constructors = do let customConstructor conName fields = recC (oldName (mkName conName)) - [varStrictType (oldName (mkName fName)) - (strictType notStrict (conT fType)) + [varBangType (oldName (mkName fName)) + (bangType bangNotStrict (conT fType)) | (fName, fType) <- fields] cons' <- for constructors $ \genCons -> do @@ -495,10 +503,12 @@ genVer tyName ver constructors = do (oldName tyName) -- no variables [] + -- no explicit kind + Nothing -- constructors (map return cons') -- not deriving anything - [] + (cxt []) return [decl] data MigrateConstructor = CopyM Name | CustomM Name ExpQ @@ -506,12 +516,14 @@ data MigrateConstructor = CopyM Name | CustomM Name ExpQ migrateVer :: Name -> Int -> [MigrateConstructor] -> Q Exp migrateVer tyName ver constructors = do -- Get information about the new version of the datatype - TyConI (DataD _cxt _name _vars cons _deriving) <- reify tyName + TyConI (DataD _cxt _name _vars _kind cons _deriving) <- reify tyName -- Let's do some checks first unless (null _cxt) $ fail "migrateVer: can't yet work with types with context" unless (null _vars) $ fail "migrateVer: can't yet work with types with variables" + unless (isNothing _kind) $ + fail "migrateVer: can't yet work with types with kinds" let oldName n = mkName (nameBase n ++ "_v" ++ show ver) diff --git a/stack.yaml b/stack.yaml index d31ff21..9703793 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-6.14 +resolver: lts-7.9 packages: - location: . @@ -6,23 +6,12 @@ packages: git: https://github.com/aelve/stache-plus commit: a12f7edf9c034a01d5da466b212b3f9c0253b1f4 extra-dep: true +- location: + git: https://github.com/liamoc/patches-vector + commit: cf29fc9d84df1ffb81d6fc82374d83b52f573746 + extra-dep: true extra-deps: -- cmark-highlight-0.2.0.0 - cmark-sections-0.1.0.2 -- friendly-time-0.4 -- ilist-0.2.0.0 -- text-all-0.3.0.1 -- text-show-3.3 -- megaparsec-5.0.1 - http-client-0.5.1 -- generic-deriving-1.10.7 -- webdriver-0.8.4 - -flags: - generic-deriving: - base-4-9: false - text-show: - base-4-9: false - template-haskell-2-11: false - new-functor-classes: false +- edit-distance-vector-1.0.0.4