github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-28 01:47:01 +03:00
Code Issues Projects Releases Wiki Activity

Move FailWithLocC into its own module.

Browse Source
This commit is contained in:
Rob Rix 2019-10-07 17:25:11 -04:00
parent 89e0185371
commit 1391e75a14
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
6 changed files with 35 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
semantic-core/src/Analysis/Concrete.hs
View File

@ -13,8 +13,8 @@ import qualified Algebra.Graph as G
import qualified Algebra.Graph.Export.Dot as G
import Analysis.Eval
import Control.Applicative (Alternative (..))
import Control.Carrier.Fail.WithLoc
import Control.Effect
import Control.Effect.Fail
import Control.Effect.Fresh
import Control.Effect.NonDet
import Control.Effect.Reader hiding (Local)

2
semantic-core/src/Analysis/ImportGraph.hs
View File

@ -8,8 +8,8 @@ module Analysis.ImportGraph
import Analysis.Eval
import Analysis.FlowInsensitive
import Control.Applicative (Alternative(..))
import Control.Carrier.Fail.WithLoc
import Control.Effect
import Control.Effect.Fail
import Control.Effect.Fresh
import Control.Effect.Reader
import Control.Effect.State

2
semantic-core/src/Analysis/ScopeGraph.hs
View File

@ -10,8 +10,8 @@ module Analysis.ScopeGraph
import Analysis.Eval
import Analysis.FlowInsensitive
import Control.Applicative (Alternative (..))
import Control.Carrier.Fail.WithLoc
import Control.Effect.Carrier
import Control.Effect.Fail
import Control.Effect.Fresh
import Control.Effect.Reader
import Control.Effect.State

2
semantic-core/src/Analysis/Typecheck.hs
View File

@ -10,8 +10,8 @@ module Analysis.Typecheck
import Analysis.Eval
import Analysis.FlowInsensitive
import Control.Applicative (Alternative (..))
import Control.Carrier.Fail.WithLoc
import Control.Effect.Carrier
import Control.Effect.Fail
import Control.Effect.Fresh as Fresh
import Control.Effect.Reader hiding (Local)
import Control.Effect.State

31
semantic-core/src/Control/Carrier/Fail/WithLoc.hs
View File

@ -1,2 +1,31 @@
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
module Control.Carrier.Fail.WithLoc
() where
( -- * Fail effect
module Control.Effect.Fail
-- * Fail carrier
, runFailWithLoc
, FailWithLocC(..)
) where
import Control.Applicative
import Control.Effect.Carrier
import Control.Effect.Error
import Control.Effect.Fail
import Control.Effect.Reader
import Data.Loc
import Prelude hiding (fail)
runFailWithLoc :: FailWithLocC m a -> m (Either (Loc, String) a)
runFailWithLoc = runError . runFailWithLocC
newtype FailWithLocC m a = FailWithLocC { runFailWithLocC :: ErrorC (Loc, String) m a }
deriving (Alternative, Applicative, Functor, Monad)
instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => MonadFail (FailWithLocC m) where
fail s = do
loc <- ask
FailWithLocC (throwError (loc :: Loc, s))
instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => Carrier (Fail :+: sig) (FailWithLocC m) where
eff (L (Fail s)) = fail s
eff (R other) = FailWithLocC (eff (R (handleCoercible other)))

26
semantic-core/src/Data/Loc.hs
View File

@ -1,21 +1,13 @@
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
module Data.Loc
( Loc(..)
, interactive
, here
, stackLoc
, FailWithLocC(..)
, runFailWithLoc
) where
import Control.Applicative
import Control.Effect.Carrier
import Control.Effect.Error
import Control.Effect.Fail
import Control.Effect.Reader
import Data.Text (Text, pack)
import GHC.Stack
import Prelude hiding (fail)
import Source.Span
data Loc = Loc
@ -38,19 +30,3 @@ stackLoc cs = case getCallStack cs of
fromGHCSrcLoc :: SrcLoc -> Loc
fromGHCSrcLoc SrcLoc{..} = Loc (pack srcLocFile) (Span (Pos srcLocStartLine srcLocStartCol) (Pos srcLocEndLine srcLocEndCol))
runFailWithLoc :: FailWithLocC m a -> m (Either (Loc, String) a)
runFailWithLoc = runError . runFailWithLocC
newtype FailWithLocC m a = FailWithLocC { runFailWithLocC :: ErrorC (Loc, String) m a }
deriving (Alternative, Applicative, Functor, Monad)
instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => MonadFail (FailWithLocC m) where
fail s = do
loc <- ask
FailWithLocC (throwError (loc :: Loc, s))
instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => Carrier (Fail :+: sig) (FailWithLocC m) where
eff (L (Fail s)) = fail s
eff (R other) = FailWithLocC (eff (R (handleCoercible other)))