TypeLenses soft-crashes when opening this file #2004
Labels
component: ghcide
type: bug
Something isn't right: doesn't work as intended, documentation is missing/outdated, etc..
Comments
|
This looks like #1951 and #1975, where the type-lens plugin doesn't handle certain pattern synonyms correctly. This is fixed, but the fix isn't in 1.2.0. Should be in the next release. As a work around, you can add explicit type signatures to the pattern synonyms, or disable the type-lens plugin. pattern FunBuilder :: (a1 -> ActionBuilder a2) -> CachedFun a1 a2
pattern BasicBuilder :: ActionBuilder a -> Cached1 Identity a(I generated those type signatures using the type-lens plugin from a trunk build of hls.) Excerpt from the log above: |
jneira
added
component: ghcide
status: fixed in master
status: needs info
|
Closing optimistically as 1.3.0 has been released, @dansanduleac feel free to reopen if you continue experiencing the bug with 1.3.0 |
jneira
removed
the
status: needs info
|
Thanks @jneira, can confirm it works fine now. |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Your environment
Output of
haskell-language-server --probe-toolsorhaskell-language-server-wrapper --probe-tools:haskell-language-server version: 1.2.0.0 (GHC: 8.10.4) (PATH: /Users/admin/.ghcup/bin/haskell-language-server-wrapper-1.2.0) (GIT hash: 8cfe8b2dbdef965ed735a66de38af425809ae48d) Tool versions found on the $PATH cabal: 3.4.0.0 stack: 2.5.1.1 ghc: Not foundWhich OS do you use: MacOS
Which lsp-client do you use: VS Code
Describe your project (alternative: link to the project):
package.yaml (excerpt):
stack.yaml
Contents of
hie.yaml:Steps to reproduce
Open my stack project.
As long as Build.hs is not an open tab, the HLS loads the project just fine.
If Build.hs is already open, or once I open it, almost immediately HLS will stop working.
Type lenses must be turned on in the config.
Here's Build.hs in its entirety.
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -- Brittany complains: Illegal keyword 'type' (use ExplicitNamespaces to enable) {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FunctionalDependencies #-} module Build ( Cached , CachedFun(..) , module Exports , Json(..) , asOracle , cacheJson , cacheMany , cacheMany' , cacheDynMany , cacheDynMany' , cachedFun , cachedFunRmap , cachedOkOrFail , decodeCached , decodeCached' , fromIO , fromIO' , parseJson , mapCachedIO , mapCachedAction , memoize , runCached , swallowErrors , type (~>) -- lenses , _cachedFunFn ) where import qualified Control.Exception.Safe as E import Prelouder hiding ( Traversing , doesFileExist , unpack ) -- Build system stuff import qualified Data.Binary as Binary import Development.Shake as Exports hiding ( (*>) ) import Development.Shake.Classes as Exports import Development.Shake.FilePath as Exports import Data.Either.Unwrap import Data.Functor.Identity import Data.Tagged import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TL import qualified Control.Category as Cat import Control.Concurrent.MVar import Control.Monad.Extra import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Reader import Control.Monad.Trans.State.Lazy import Control.Monad.Validate import qualified Data.ByteString.Lazy as LBS import Data.Set as Set import qualified System.Directory as IO import Control.Concurrent.Extra import Control.Monad.Morph ( hoist ) import Control.Monad.Trans.Writer.Strict import Data.Bifunctor import qualified Data.HashMap.Strict as HM import Data.Profunctor import Data.Profunctor.Traversing import Data.Profunctor.Unsafe import Data.Proxy ( Proxy(..) ) import Debug.Trace ( trace , traceIO ) import qualified Development.Shake as Shake import GHC.Stack ( HasCallStack ) import qualified Prelouder as P type Errs = [Text] -- <*> High-level functions -- | Cache the json-able value produced by the given 'Cached'. cacheJson :: (FromJSON a, ToJSON a) => FilePath -- ^ output path -> Cached a -> Rules (Cached a) cacheJson path = cacheIO path (encodeFile path) (mapLeft pack <$> eitherDecodeFileStrict path) parseJson :: FromJSON a => FilePath -> Cached a parseJson path = fromIO' [path] ( Identity . ExceptT $ mapLeft ((: []) . pack) <$> eitherDecodeFileStrict path ) -- | It's normally impossible to map Cached through an IO effect, so this function allows that. mapCachedIO :: (Functor f, IsCache c, F c ~ f) => (Set FilePath -> a -> ExceptT [Text] Action b) -> c a -> c b mapCachedIO f = mapCachedIO' f' where f' needs = lift . exceptToValidateLiftedWith id . f needs mapCachedIO' :: (Functor f, IsCache c, F c ~ f) => (Set FilePath -> a -> WithFinalizer ValidateIO b) -> c a -> c b mapCachedIO' f = internal . _Wrapped . mapped %~ mapBuilderTemplate (bindTemplate f) mapCachedAction :: (Functor f, IsCache c, F c ~ f) => (Action ~> Action) -> c a -> c a mapCachedAction f = internal . _Wrapped . mapped %~ mapBuilderTemplate (wrap f) where wrap (f :: Action ~> Action) ActionTemplate { readValue, needs } = ActionTemplate { readValue = mapWriterT -- it's really a pain to unwrap and rewrap a ValidateT ( exceptToValidateLiftedWith id . ExceptT . f . runValidateT ) readValue , needs } bindTemplate :: Monad mt => (Set FilePath -> a -> WithFinalizer mt b) -> ActionTemplateT mt a -> ActionTemplateT mt b bindTemplate f ActionTemplate { readValue, needs } = ActionTemplate { readValue = readValue >>= f needs, needs } -- Absorb an explicit error into the cache read operation. cachedOkOrFail :: (Functor f, IsCache c, F c ~ f) => (e -> [Text]) -> c (Either e b) -> c b cachedOkOrFail f = mapCachedIO (const $ except . mapLeft f) {-# INLINE cachedOkOrFail #-} swallowErrors :: IsCache c => c (Either [Text] a) -> c a swallowErrors = over internal (cachedOkOrFail id) -- | Memoize a 'CachedFun' so its read action only ever gets run once per k. memoize :: ShakeValue k => CachedFun k a -> Rules (CachedFun k a) memoize (FunBuilder builder) = do -- here, want to unwrap then re-wrap ActionBuilder... let fAction = Prelouder.first builder >>> (\(ActionBuilder a, r) -> runReaderT a r) cached <- newCache fAction return . CachedFun $ (curry cached >>> ReaderT >>> ActionBuilder >>^ BasicBuilder) data InputValue t k a = InputValue { key :: Tagged t k , ctx :: Ctx -- TODO do we need valueProxy? } deriving (Generic, Show, Typeable, Eq, Hashable, NFData) instance Hashable k => Hashable (Tagged t k) where hashWithSalt salt (untag -> k) = hashWithSalt salt k instance Binary k => Binary (InputValue t k a) where put InputValue { key, ctx } = Binary.put (untag key) >> Binary.put ctx get = (\(Tagged -> key) ctx -> InputValue { key, ctx }) <$> Binary.get <*> Binary.get type instance RuleResult (InputValue ctx k a) = a -- NOTE: this is to test the generalisation of 't' across different kinds -- baz :: forall t. (ShakeValue (InputValue t () ())) => Rules (InputValue t () () -> Action ()) -- baz :: forall (t :: forall k. k). (ShakeValue (Tagged t ())) => Rules (InputValue t () () -> Action ()) baz :: forall k (t :: k) . (Typeable t, Typeable k) => Rules (InputValue t () () -> Action ()) baz = addOracle (\InputValue { key, ctx } -> return ()) newtype Foo = Foo () deriving (Generic, Show, Typeable, Eq) deriving anyclass (Hashable, Binary, NFData) data Bar = X | Y deriving (Generic, Show, Typeable, Eq) deriving anyclass (Hashable, Binary, NFData) tryThis00 = baz @_ @Foo tryThis10 = baz @_ @X tryThis11 = baz :: Rules (InputValue 'X () () -> Action ()) -- | Mark the function 'CacheFun k a' as an oracle, so that the action -- reruns whenever the function returns something else compared to previous runs. asOracle :: forall tk (t :: tk) k a . (ShakeValue (InputValue t k a), ShakeValue a) => Proxy t -> CachedFun k a -> Rules (CachedFun k a) asOracle _ (CachedFun fb) = do oracle <- addOracle $ \(InputValue { key, ctx } :: InputValue t k a) -> -- fprintln ("Asking for " % shown) key -- before, builder = the cachedBuilder -- now it's flip runReaderT ctx . flatToAction . fb . untag $ key return . CachedFun . rmap (BasicBuilder . ActionBuilder) $ newAction oracle where newAction oracle k = do -- fprintln ("Oracle asked: " % shown) k ctx <- ask result <- lift $ oracle (InputValue (Tagged k) ctx) return $ pure result flatToAction (BasicBuilder (ActionBuilder b)) = b >>= (lift . actionTemplateToAction) -- | Decode a 'Cached' 'ByteString' value as JSON. decodeCached :: (Functor f, IsCache c, F c ~ f, FromJSON a) => c LBS.ByteString -> c a decodeCached = toExternal . mapCachedIO (\_ (Right a) -> pure a) . decodeCached' . fmap Right . toInternal -- | Decode a 'Cached' 'ByteString' value as JSON, allowing for user errors. decodeCached' :: (Functor f, IsCache c, F c ~ f, FromJSON a, m ~ Either e) => c (m LBS.ByteString) -> c (m a) decodeCached' = mapCachedIO (\needs -> \case Left x -> ExceptT . pure . pure $ Left x Right y -> withExceptT ( sformat ( "Failed to decode cached JSON value from files " % build % ": " % string ) (Set.toList needs) >>> (: []) ) . ExceptT . pure . fmap pure . eitherDecode' $ y ) class Cacheable c d | c -> d where readFrom :: FilePath -> IO (Either Text c) writeTo :: FilePath -> c -> IO () unpack :: c -> d newtype Json a = Json a instance Cacheable LBS.ByteString LBS.ByteString where readFrom = fmap Right . LBS.readFile writeTo = LBS.writeFile unpack = id instance (FromJSON a, ToJSON a) => Cacheable (Json a) a where readFrom = fmap (right Json . left pack) . eitherDecodeFileStrict' writeTo fp (Json a) = encodeFile fp a unpack (Json a) = a cacheMany :: Cacheable c d => FilePath -- ^ root path -> (id -> String) -- ^ id to path segment (without extension) -> (String -> id) -- ^ path segment (without extension) to id -> String -- ^ extension -> (id -> Cached c) -- ^ compute -> Rules (CachedFun id d) cacheMany rootPath idToPath pathToId ext compute = cachedFunRmap (cachedOkOrFail (\() -> [])) <$> cacheMany' rootPath idToPath pathToId ext (compute >>^ fmap Right) -- | Cache many files. In case an exception occurs, it will be stored instead. cacheMany' :: (ToJSON e, FromJSON e, Cacheable c d) => FilePath -- ^ root path -> (id -> String) -- ^ id to path segment (without extension) -> (String -> id) -- ^ path segment (without extension) to id -> String -- ^ extension -> (id -> Cached (Either e c)) -- ^ compute -> Rules (CachedFun id (Either e d)) -- cacheMany rootPath idToPath id | isAbsolute $ idToPath id = -- error "idToPath should return a relative path" cacheMany' rootPath idToPath pathToId ext compute = rmap (fmap unpack) . CachedFun <$> cacheIO' (rootPath <//> "*") path writeAction readAction (\path idToA -> idToA . pathToId $ takeBaseName path) compute where readAction = jsonReadAction . path writeAction = jsonWriteAction . path path id = rootPath </> idToPath id <.> ext jsonWriteAction :: (Cacheable c d, ToJSON a) => FilePath -> Either a c -> WithFinalizer IO () jsonWriteAction path = let goodPath = path badPath = failedPath path writeGood = writeTo path writeFailed = encodeFile badPath in either (\err -> do liftIO $ writeTo path LBS.empty >> writeFailed err tell $ trackWrite [badPath] ) (\ok -> liftIO $ do writeGood ok -- Here we don't use Shake.doesFileExist since we delete the file -- as a cleanup, we don't want it to be tracked as a dep. -- Also docs say the result of doesFileExist shouldn't change from -- the beginning to the end of the build. whenM (IO.doesFileExist badPath) (IO.removeFile badPath) ) jsonReadAction :: (FromJSON a, Cacheable c d) => FilePath -> WithFinalizer IO (Either Text (Either a c)) jsonReadAction path = do let badPath = failedPath path failedFileExists <- liftIO $ P.doesFileExist badPath -- have shake register that we asked for this file tell . void $ Shake.doesFileExist badPath if failedFileExists then liftIO $ fmap join . tryInner . fmap (left pack . fmap Left) . eitherDecodeFileStrict' $ badPath else liftIO $ fmap join . tryInner . fmap (right Right) . readFrom $ path where tryInner = fmap (mapLeft (pack . show)) . E.tryAny failedPath :: FilePath -> FilePath failedPath path = path <.> "failed" cacheDynMany :: (Eq id, Hashable id, Cacheable c d) => FilePath -- ^ root path -> (id -> String) -- ^ id to path (including extension) -> (id -> Cached c) -- ^ compute -> Rules (CachedFun id d) cacheDynMany rootPath idToPath compute = over _cachedFunFn (rmap $ cachedOkOrFail (\() -> [])) <$> cacheDynMany' rootPath idToPath (compute >>^ fmap Right) cacheDynMany' :: (Eq id, Hashable id, ToJSON e, FromJSON e, Cacheable c d) => FilePath -- ^ root path -> (id -> String) -- ^ id to subpath (including extension) -> (id -> Cached (Either e c)) -- ^ compute -> Rules (CachedFun id (Either e d)) cacheDynMany' rootPath idToPath compute = rmap (fmap unpack) <$> dynCacheIO (rootPath <//> "*") path writeAction readAction compute where readAction = jsonReadAction . path writeAction = jsonWriteAction . path path id = rootPath </> idToPath id -- also, lift function fromIO :: Functor f => [FilePath] -> f (IO a) -> Cached1 f a fromIO needs fio = fromIO' needs (lift <$> fio) fromIO' :: Functor f => [FilePath] -> f (ExceptT Errs IO a) -> Cached1 f a fromIO' needs = fromIOWithFinalizer needs . fmap lift fromIOWithFinalizer :: Functor f => [FilePath] -> f (WithFinalizer (ExceptT Errs IO) a) -> Cached1 f a fromIOWithFinalizer (Set.fromList -> needs) fio = Cached1 $ makeBuilder . hoist (exceptToValidateLiftedWith id . hoist liftIO . tryInner) <$> fio where tryInner = either (throwE . (: []) . pack . show) pure <=< E.tryAny makeBuilder readValue = ActionBuilder $ do return $ ActionTemplate { readValue, needs } -- | A convenient way to print a trace using a formatter. tracedf :: Format (Action ()) a -> a tracedf f = runFormat f formatter where formatter fmt = traced (TL.unpack . TL.toLazyText $ fmt) (pure ()) -- | Caching with arbitrary IO actions, specialized to Cached. cacheIO :: FilePath -> (a -> IO ()) -> IO (Either Text a) -> Cached a -> Rules (Cached a) cacheIO path write read = fmap runIdentity . cacheIO' path (Identity path) (Identity . rmap liftIO $ write) (Identity . liftIO $ read) (const runIdentity) . Identity -- | A generalized way to cache multiple files under a rootPattern. -- I don't know if [f] makes sense to be anything else besides a function -- [(->) id]. -- -- Uses a single shake rule, but needs a 'selector' to recover the -- computation from a given file's base name. cacheIO' :: forall f a . (Monad f) => FilePattern -- ^ rootPattern -> f FilePath -- ^ fPath -> f (a -> WithFinalizer IO ()) -- ^ fWrite -> f (WithFinalizer IO (Either Text a)) -- ^ fRead -> (forall a . FilePath -> f a -> a) -- ^ selector -> f (Cached a) -> Rules (f (Cached a)) cacheIO' rootPattern fPath fWrite fRead selector fCached = -- if isBuilt path (cacheBuild a) -- then CacheFail ("The cache file already exists: " <> pack path) saveCachedRule $> (readSavedCached <$> fPath <*> fRead) where selector' :: Selector f selector' = rmap pure . selector -- Rule that computes and saves the cached value. saveCachedRule = buildOne rootPattern selector' saveCached -- Read the value for the output, ideally reads what was saved by 'saveCached' -- void action that reads the fCached and saves it using fWrite. -- NOTE: not sure if this can work with anything else but Identity, i.e. -- fCached :: f (Cached1 Identity a) saveCached = do write <- fWrite basicBuilder . mapCachedIO' (const $ hoist liftIO . write) <$> fCached -- tryInner = validateT . mapLeft ((: []) . pack . show) <=< E.tryAny --------------------------------------------------------------------------- readSavedCached path read = BasicBuilder (makeReadAction path read) makeReadAction path read = ActionBuilder $ do -- Ensure rootPattern matches path unless (rootPattern ?== path) (fail $ "Bad path: " ++ path) return ActionTemplate { readValue = (validateT <=< hoist liftIO) $ Data.Bifunctor.first errMsg <$> read , needs = Set.singleton path } where errMsg e = ["Error reading file " <> pack path <> ": " <> e] -- Caching a function where we automatically keep track of which inputs produced which resulting path. dynCacheIO :: (HasCallStack, Eq i, Hashable i) => FilePattern -- ^ rootPattern -> (i -> FilePath) -- ^ fPath -> (i -> a -> WithFinalizer IO ()) -- ^ fWrite -> (i -> WithFinalizer IO (Either Text a)) -- ^ fRead -> (i -> Cached a) -> Rules (CachedFun i a) dynCacheIO rootPattern fPath fWrite fRead fCached = do -- Create the rule to save the results, but only once per key -- The second time this is retrieved for the same key, it will do nothing. -- idFromPath :: FilePath -> Action i idToPathMap <- liftIO $ newVar HM.empty saveCachedRule (lookupFromCache idToPathMap) $> CachedFun (\i -> do let path = fPath i liftIO (saveToCache idToPathMap path i) readSavedCached path (fRead i) ) where lookupFromCache var k = fromJust . HM.lookup k <$> liftIO (readVar var) saveToCache var k value = modifyVar_ var $ pure . HM.insert k value -- Rule that computes and saves the cached value. -- f is 'Kleisli Action i a' saveCachedRule pathToId = buildOne rootPattern (selector pathToId) saveCached -- Use pathToId to figure out the id, then flatmap that onto the 2nd "idToAction" -- parameter (i.e. saveCached) selector pathToId = \path idToAction -> pathToId path >>= runKleisli idToAction saveCached = arr $ \i -> saveCached' (rmap (hoist liftIO) (fWrite i)) (fCached i) saveCached' write = basicBuilder . mapCachedIO' (const write) -- tryInner = validateT . mapLeft ((: []) . pack . show) <=< E.tryAny --------------------------------------------------------------------------- readSavedCached path read = Cached1 { cacheBuilder = Identity $ makeReadAction path read } makeReadAction path read = ActionBuilder $ do -- Ensure rootPattern matches path unless (rootPattern ?== path) (fail $ "Bad path: " ++ path) return ActionTemplate -- TODO tryInner { readValue = (validateT <=< hoist liftIO) $ Data.Bifunctor.first errMsg <$> read , needs = Set.singleton path } where errMsg e = ["Error reading file " <> pack path <> ": " <> e] -- buildOne with Kleisli Action id a -- selector :: FilePath -> Kleisli Action id a -> a -- i.e. 'id -> Action a' -- we can have 'FilePath -> Action id'... looking it up using the newCache -- =========> we will need selector to return Action a -- Retrieve an 'a' back from an 'f a' container, based on a file path type Selector f = forall a . FilePath -> f a -> Action a -- | Build one rule under FilePattern, that can handle multiple files according to the selector. buildOne :: FilePattern -> Selector f -> f (ActionBuilder ()) -> Rules () buildOne ptn selector fWrite = ptn %> \outPath -> do -- since i know the paths in advance, can i prebuild a 'FilePath -> ActionBuilder ()' ? ActionBuilder builder <- selector outPath fWrite let ctx = Ctx { ruleName = Just $ T.pack ptn } ActionTemplate { readValue, needs } <- runReaderT builder ctx need (Set.toList needs) -- e <- traced "Writing cache" $ runValidateT . runWriterT $ readValue e <- runValidateT . runWriterT $ readValue tracedf "Writing cache" case e of Right ((), finalizer) -> finalizer Left err -> fail $ "Error running shake rule building file " <> outPath <> " which needs " <> show needs <> "\nError messages:\n" <> formatErrors err formatErrors :: [Text] -> String formatErrors errs = TL.unpack $ TL.intercalate "\n" (fmap formatError errs) where formatError = (" * " <>) . indentFurtherLines . TL.fromStrict indentFurtherLines = TL.unlines . uncurry (++) . P.second (fmap (" " <>)) . P.splitAt 1 . TL.lines pattern BasicBuilder { basicBuilder } = Cached1 { cacheBuilder = Identity basicBuilder } _basicBuilder :: Iso (Cached1 Identity a) (Cached1 Identity b) (ActionBuilder a) (ActionBuilder b) _basicBuilder = _Wrapped . _Wrapped -- TODO used? funBuilder :: (k -> ActionTemplate a) -> k -> ActionBuilder a funBuilder f = f >>> ActionBuilder . pure -- -> | State with Action. -- toAction :: (Monad m, ca ~ Cached a) => ca -> ShakeStateT m a -- toAction (CacheFail err) = pure $ fail $ unpack err -- toAction c@Cached1 { cacheBuilder } = state (const action &&& (<> cacheRules)) -- where -- action = do -- let ActionBuilder builder = runIdentity cacheBuilder -- result <- builder -- actionTemplateToAction result -- withAction :: Monad m => ShakeStateT m a -> (a -> Action b) -> ShakeStateT m b -- withAction ss f = (>>= f) <$> ss -- | Run a shake build, returning the result of the given action. runCached :: (HasCallStack, MonadIO m) => Rules (Cached a) -> m a runCached rules = do result <- liftIO newEmptyMVar let rules' = rules >>= action . runAndSaveCached result liftIO $ shake options rules' liftIO $ readMVar result where runAndSaveCached result cached = runCached cached >>= liftIO . putMVar result runCached (Cached1 cacheBuilder) = flip runReaderT defaultCtx $ do let ActionBuilder builder = runIdentity cacheBuilder result <- builder lift $ actionTemplateToAction result options = shakeOptions { shakeThreads = 0 , shakeReport = ["build/report.html"] } -- <*> Internal Functions type ValidateIO = ValidateT [Text] Action -- | Copied from 'Control.Monad.Validate.Class' but meant to work more as a hoist for -- 'ExceptT' rather expecting a 'MonadValidate' inside of it. exceptToValidateLiftedWith :: forall e1 e2 m a . (Monad m, Semigroup e2) => (e1 -> e2) -> ExceptT e1 m a -> ValidateT e2 m a exceptToValidateLiftedWith f = validateT . left f <=< lift . runExceptT {-# INLINE exceptToValidateLiftedWith #-} validateT :: MonadValidate e m => Either e a -> m a validateT = either refute pure {-# INLINE validateT #-} -- f (ActionBuilder (t a)) -> ValidateT [Text] (f . ActionBuilder) -- collect :: Functor f => (a -> g b) -> f a -> g (f b) -- () -- https://hackage.haskell.org/package/profunctors-5.5.2/docs/Data-Profunctor-Traversing.html#t:Traversing -- Profunctor p => Traversing (CofreeTraversing p) -- traverse :: Applicative f => (a -> f b) -> t a -> f (t b) -- wander :: (forall f. Applicative f => (a -> f b) -> s -> f t) -> p a b -> p s t -- here, s=[a], t=[b], -- it becomes :: (forall f. Applicative f => (a -> f b) -> [a] -> f [b]) -- this is just fmap! -- (a -> b) -> (t a -> t b) -- CF a b -> CF (t a) (t b) -- flatmapCached -- :: (Functor f, IsCache c, F c ~ f) -- => (a -> f b) -- -> Cached1 f a -- -> CachedFun a b -- -> Cached1 h c -- flatmapCached f cf cg = Cached1 { cacheBuilder = applyCached -- -- f (ActionBuilder a) -- -- g (ActionBuilder b) -- -- h (ActionBuilder c) -- , cacheRules = cacheRules cf <> cacheRules cg -- } -- where -- -- can I lift function into CachedFun a (g b -> h c) -- lifted = arr f :: CachedFun a (g b -> h c) -- | Hoist a 'Cached1' f instance to a 'Cached1' g instance given a -- natural transformation 'f ~> g'. -- TODO consider deleting hoistCached :: (f ~> g) -> (Cached1 f ~> Cached1 g) hoistCached f Cached1 { cacheBuilder } = Cached1 { cacheBuilder = f cacheBuilder } type (~>) f g = forall x . f x -> g x -- <*> Cached1 implementation newtype Cached1 f a = Cached1 { cacheBuilder :: f (ActionBuilder a) } deriving (Functor, Generic) instance Wrapped (Cached1 f a) instance Rewrapped (Cached1 f a) (Cached1 f b) type Cached a = Cached1 Identity a ---------------------------------------------------------------------------- -- | Convenience rmap on the inner Cached of a CachedFun. cachedFunRmap :: (Cached a1 -> Cached a2) -> CachedFun i a1 -> CachedFun i a2 cachedFunRmap = over (_cachedFunFn . mapped) newtype CachedFun i a = CachedFun { runCachedFun :: i -> Cached a } deriving Functor deriving newtype (Semigroup, Monoid) -- | Lift an IO function to a CachedFun. cachedFun :: (i -> IO a) -> CachedFun i a cachedFun f = CachedFun $ fromIO mempty . Identity . f instance Applicative (CachedFun i) where pure = CachedFun . const . pure liftA2 op (CachedFun a) (CachedFun b) = CachedFun $ \i -> liftA2 op (a i) (b i) instance Cat.Category CachedFun where id = CachedFun pure (CachedFun f) . (CachedFun g) = CachedFun $ \i -> BasicBuilder $ basicBuilder (g i) >>= (basicBuilder . f) instance Arrow CachedFun where arr f = CachedFun $ pure . f (CachedFun ra) *** (CachedFun rb) = CachedFun (foo ra rb) where foo a b = a *** b >>> uncurry (liftA2 (,)) instance Profunctor CachedFun where lmap f (CachedFun cf) = CachedFun $ cf . f rmap = fmap deriving via Kleisli (Cached1 Identity) instance Choice CachedFun deriving via Kleisli (Cached1 Identity) instance Strong CachedFun deriving via Kleisli (Cached1 Identity) instance Traversing CachedFun deriving via Kleisli (Cached1 Identity) instance ArrowApply CachedFun ----------------------------------------------------------------------------- -- Extract the builder from a CachedFun as a function. pattern FunBuilder fb <- (CachedFun (rmap (runIdentity . cacheBuilder) -> fb)) -- | 'CachedFun' as a plain function to 'Cached'. _cachedFunFn :: Iso (CachedFun i a) (CachedFun i b) (i -> Cached a) (i -> Cached b) _cachedFunFn = iso runCachedFun CachedFun -- TODO if we drop f from Cached1, this won't matter anymore. -- | Absorb an external functor over a plain 'Cached' into the 'Cached1'. absorbF :: Functor f => Iso (f (Cached1 Identity a)) (f (Cached1 Identity b)) (Cached1 f a) (Cached1 f b) absorbF = iso (Cached1 . fmap basicBuilder) (fmap BasicBuilder . cacheBuilder) -- type family Cache (f :: * -> *) a where -- Cache ((->) k) a = CachedDynFun k a -- Cache Identity a = Cached1 Identity a class (Functor (F c)) => IsCache c where type F c :: * -> * toExternal :: Cached1 (F c) a -> c a toInternal :: c a -> Cached1 (F c) a internal :: Iso (c a) (c b) (Cached1 (F c) a) (Cached1 (F c) b) internal = iso toInternal toExternal toInternal = withIso internal const toExternal = withIso internal (\ _ y -> y) instance (Functor f) => IsCache (Cached1 f) where type F (Cached1 f) = f toInternal = id toExternal = id instance IsCache (CachedFun i) where type F (CachedFun i) = (->) i internal = _cachedFunFn . absorbF -- <*> Instances (and their implementation) instance MonadIO (Cached1 Identity) where liftIO = fromIO mempty . Identity instance (Applicative f) => Applicative (Cached1 f) where pure x = Cached1 { cacheBuilder = pure $ pure x } liftA2 op fa fb = Cached1 { cacheBuilder = liftA2 (liftA2 op) (cacheBuilder fa) (cacheBuilder fb) } instance MonadValidate Errs ActionBuilder where refute e = ActionBuilder . pure -- $ ActionTemplate { needs = Set.empty, readValue = refute e } tolerate = mapBuilderTemplate tolerateInner where tolerateInner at = at { readValue = tolerate (readValue at) } -- Not sure how to derive it in cases other than Identity. -- Also don't think we need to. deriving via ActionBuilder instance Monad (Cached1 Identity) deriving via ActionBuilder instance MonadValidate Errs (Cached1 Identity) actionTemplateToAction :: ActionTemplate a -> Action a actionTemplateToAction ActionTemplate { readValue, needs } = do need $ Set.toList needs (result, finalizer) <- either (fail . formatErrors) pure =<< (runValidateT . runWriterT $ readValue) finalizer return result -- ioToAction = traced ("Reading result of " ++ show needs) -- | Context about what is being built. data Ctx = Ctx { ruleName :: Maybe Text } deriving (Generic, Show, Typeable, Eq, Hashable, NFData, Binary) defaultCtx = Ctx Nothing type NormalIO = ExceptT [Text] Action type ActionBuilder = ActionBuilderT ValidateIO type CtxAction = ReaderT Ctx Action newtype ActionBuilderT m a = ActionBuilder { actionBuilder :: CtxAction (ActionTemplateT m a) } deriving (Functor) hoistBuilderT :: Monad f => (f ~> g) -> ActionBuilderT f ~> ActionBuilderT g hoistBuilderT f (ActionBuilder builder) = ActionBuilder $ over _readValue (hoist f) <$> builder -- | Map the 'ActionTemplateT' inside an 'ActionBuilderT' mapBuilderTemplate :: (ActionTemplateT m a -> ActionTemplateT m b) -> ActionBuilderT m a -> ActionBuilderT m b mapBuilderTemplate f (ActionBuilder a1) = ActionBuilder $ f <$> a1 type ActionTemplate = ActionTemplateT ValidateIO -- | The building blocks necessary to produce an 'Action'. data ActionTemplateT mt a = ActionTemplate { readValue :: WithFinalizer mt a , needs :: Set FilePath } deriving Functor type WithFinalizer = WriterT (Action ()) -- _writer :: m ~> n -> Lens (WriterT w m a) (WriterT w n b) (m a) (n b) -- _writer f = lens -- (fmap fst . runWriterT) -- (\w b -> mapWriterT (liftA2 (\b a -> a & _1 .~ b) b . f) w) _readValue :: Lens (ActionTemplateT f a) (ActionTemplateT g b) (WriterT (Action ()) f a) (WriterT (Action ()) g b) _readValue = lens readValue (\template b -> template { readValue = b }) instance Applicative mt => Applicative (ActionTemplateT mt) where pure x = ActionTemplate { readValue = pure x, needs = Set.empty } liftA2 op fa fb = ActionTemplate { readValue = liftA2 op (readValue fa) (readValue fb) , needs = needs fa <> needs fb } instance (Semigroup a, Applicative mt) => Semigroup (ActionTemplateT mt a) where a <> b = liftA2 (<>) a b instance Applicative m => Applicative (ActionBuilderT m) where pure x = ActionBuilder (pure . pure $ x) liftA2 op (ActionBuilder fa) (ActionBuilder fb) = ActionBuilder $ (liftA2 . liftA2 $ op) fa fb instance Monad ActionBuilder where (ActionBuilder ma) >>= famb = ActionBuilder $ do actionTemplate <- ma -- traced -- (formatToString ("ActionTemplate: " % shown) (needs actionTemplate)) -- (pure ()) value <- lift $ actionTemplateToAction actionTemplate -- don't know how to expose the 'either' so -- dealing with it inside the Action let ActionBuilder mb = famb value mb instance (Monoid a, Applicative f) => Monoid (Cached1 f a) where mempty = pure mempty instance (Semigroup a, Applicative f) => Semigroup (Cached1 f a) where a <> b = Cached1 { cacheBuilder = liftA2 combineBuilders (cacheBuilder a) (cacheBuilder b) } where combineBuilders (ActionBuilder a) (ActionBuilder b) = ActionBuilder $ liftA2 (<>) a bAnd Prelouder.hs
```haskell module Prelouder ( module Exports , fprintln , makeGettable , print , putStr , putStrLn ) where-- Exports
import Prelude as Exports
hiding ( fail
, print
, putStr
, putStrLn
, readFile
, uncons
, writeFile
)
import Control.Applicative as Exports
import Control.Arrow as Exports
import Control.Exception.Safe as Exports
import Control.Lens as Exports
hiding ( (<.>)
, element
)
import Control.Lens.Operators as Exports
hiding ( (<.>) )
import Control.Monad as Exports
hiding ( fail )
import Control.Monad.Extra as Exports
( whenJust )
import Control.Monad.Fail as Exports
( MonadFail(..) )
import Control.Monad.IO.Class as Exports
import Control.Monad.Trans.Except as Exports
( Except
, ExceptT(ExceptT)
, except
, mapExcept
, mapExceptT
, runExcept
, runExceptT
, withExcept
, withExceptT
)
import Data.Bool as Exports
import Data.Either as Exports
import Data.Foldable as Exports
import Data.Functor as Exports
import Data.Hashable as Exports
import Data.Int as Exports
import Data.List as Exports
hiding ( uncons )
import Data.Maybe as Exports
import Data.Monoid as Exports
import Data.Scientific as Exports
( Scientific )
import qualified Data.Scientific as Exports.Sci
import Data.String as Exports
import Data.Text as Exports
( Text
, pack
, unpack
)
import qualified Data.Text.Lazy
import Data.Traversable as Exports
import Data.Tuple as Exports
import GHC.Generics as Exports
( Generic )
import System.Directory as Exports
import System.FilePath as Exports
import Text.Printf as Exports
-- Trialling formatting library
import Formatting as Exports
hiding ( left
, right
)
import Formatting.Formatters as Exports
( commas
, fixed
, ords
, plural
, sci
, shortest
, shown
, stext
, string
)
-- Aeson re-exports
import Data.Aeson as Exports
hiding ( (.=) )
import Data.Aeson.Types as Exports
( (.:)
, (.:?)
, FromJSON(..)
, ToJSON(..)
, Value(..)
, withArray
, withObject
)
-- Internal
import qualified Data.Text.IO
import qualified Data.Text.Lazy.Builder as T
import qualified Data.Text.Lazy.IO as T
import qualified Prelude as P
hiding ( fail )
-- Some lens stuff
makeGettable = makeLensesWith (lensRules & generateUpdateableOptics .~ False)
-- IO
putStr :: MonadIO m => Text -> m ()
putStr = liftIO . Data.Text.IO.putStr
putStrLn :: MonadIO m => Text -> m ()
putStrLn = liftIO . Data.Text.IO.putStrLn
print :: (MonadIO m, Show a) => a -> m ()
print = liftIO . P.print
fprintln :: MonadIO m => Format (m ()) a -> a
fprintln m = runFormat m (liftIO . T.putStrLn . T.toLazyText)
haskell-language-server-8.10.4: Maybe.fromJust: Nothing
CallStack (from HasCallStack):
error, called at libraries/base/Data/Maybe.hs:148:21 in base:Data.Maybe
fromJust, called at src/Development/IDE/Plugin/TypeLenses.hs:283:18 in ghcide-1.4.0.0-inplace:Development.IDE.Plugin.TypeLenses
2021-07-06 00:29:19.740563 [ThreadId 1293] INFO hls: File: /Users/admin/code/deep-value/Setup.hs
Hidden: no
Range: 1:8-1:27
Source: not found
Severity: DsError
Message:
Could not load module ‘Distribution.Simple’
It is a member of the hidden package ‘Cabal-3.2.1.0’.
You can run ‘:set -package Cabal’ to expose it.
(Note: this unloads all the modules in the current scope.)
...
2021-07-06 00:29:23.878926 [ThreadId 2106] INFO hls: finish: GetHie (took 0.03s)
Files that failed:
2021-07-06 00:29:23.879824 [ThreadId 2107] INFO hls: finish: GenerateCore (took 0.00s)
Completed (43 files worked, 9 files failed)
haskell-language-server-wrapper: callProcess: /Users/admin/.ghcup/bin/haskell-language-server-8.10.4 "--debug" "." (exit 9): failed
[client] run command: "haskell-language-server-wrapper --lsp"
[client] debug command: "haskell-language-server-wrapper --lsp"
[client] server cwd: undefined
Found "/Users/admin/code/deep-value/hie.yaml" for "/Users/admin/code/deep-value/a"
Run entered for haskell-language-server-wrapper(haskell-language-server-wrapper) Version 1.2.0.0, Git revision 8cfe8b2 (dirty) x86_64 ghc-8.10.4
Current directory: /Users/admin/code/deep-value
Operating system: darwin
Arguments: ["--lsp"]
Cradle directory: /Users/admin/code/deep-value
Cradle type: Stack
Tool versions found on the $PATH
cabal: 3.4.0.0
stack: 2.5.1.1
ghc: Not found
Consulting the cradle to get project GHC version...
Project GHC version: 8.10.4
haskell-language-server exe candidates: ["haskell-language-server-8.10.4","haskell-language-server"]
Launching haskell-language-server exe at:/Users/admin/.ghcup/bin/haskell-language-server-8.10.4
haskell-language-server version: 1.2.0.0 (GHC: 8.10.4) (PATH: /Users/admin/.ghcup/bin/haskell-language-server-8.10.4~1.2.0) (GIT hash: 8cfe8b2)
Starting (haskell-language-server)LSP server...
with arguments: GhcideArguments {argsCommand = LSP, argsCwd = Nothing, argsShakeProfiling = Nothing, argsTesting = False, argsExamplePlugin = False, argsDebugOn = False, argsLogFile = Nothing, argsThreads = 0, argsProjectGhcVersion = False}
with plugins: [PluginId "pragmas",PluginId "floskell",PluginId "fourmolu",PluginId "tactics",PluginId "ormolu",PluginId "stylish-haskell",PluginId "retrie",PluginId "brittany",PluginId "class",PluginId "haddockComments",PluginId "eval",PluginId "importLens",PluginId "refineImports",PluginId "moduleName",PluginId "hlint",PluginId "splice",PluginId "ghcide-hover-and-symbols",PluginId "ghcide-code-actions-imports-exports",PluginId "ghcide-code-actions-type-signatures",PluginId "ghcide-code-actions-bindings",PluginId "ghcide-code-actions-fill-holes",PluginId "ghcide-completions",PluginId "ghcide-type-lenses",PluginId "ghcide-core"]
in directory: /Users/admin/code/deep-value
Starting LSP server...
If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!
Started LSP server in 0.00s
setInitialDynFlags cradle: Cradle {cradleRootDir = "/Users/admin/code/deep-value", cradleOptsProg = CradleAction: Stack}
2021-07-06 00:21:58.947494 [ThreadId 5] INFO hls: Registering ide configuration: IdeConfiguration {workspaceFolders = fromList [NormalizedUri (-4486092460564443533) "file:///Users/admin/code/deep-value"], clientSettings = hashed Nothing}
2021-07-06 00:21:58.962617 [ThreadId 106] INFO hls: Consulting the cradle for "src/Build.hs"
Output from setting up the cradle Cradle {cradleRootDir = "/Users/admin/code/deep-value", cradleOptsProg = CradleAction: Stack}
The text was updated successfully, but these errors were encountered: