msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

SrcSpan

Browse Source
This commit is contained in:
crumbtoo
2024-02-16 16:13:40 -07:00
parent a72b771506
commit 953086d751
6 changed files with 98 additions and 39 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
src/Compiler/RLPC.hs
View File

@@ -220,9 +220,9 @@ docRlpcErr msg = header
rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|")
srclines = ["", "<problematic source code>", ""]
filename = msgColour "<input>"
pos = msgColour $ tshow (msg ^. msgSpan . srcspanLine)
pos = msgColour $ tshow (msg ^. msgSpan . srcSpanLine)
<> ":"
<> tshow (msg ^. msgSpan . srcspanColumn)
<> tshow (msg ^. msgSpan . srcSpanColumn)
header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": "
<> errorColour "error" <> msgColour ":"

47
src/Compiler/Types.hs
View File

@@ -1,12 +1,11 @@
{-# LANGUAGE TemplateHaskell #-}
module Compiler.Types
( SrcSpan(..)
, srcspanLine, srcspanColumn, srcspanAbs, srcspanLen
, srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen
, Located(..)
, _Located
, located
, nolo
, (<<~), (<~>), (<#>)
-- * Re-exports
, Comonad
@@ -18,7 +17,7 @@ module Compiler.Types
import Control.Comonad
import Data.Functor.Apply
import Data.Functor.Bind
import Control.Lens hiding ((<<~))
import Control.Lens hiding ((<<~))
import Language.Haskell.TH.Syntax (Lift)
--------------------------------------------------------------------------------
@@ -47,53 +46,35 @@ data SrcSpan = SrcSpan
!Int -- ^ Column
!Int -- ^ Absolute
!Int -- ^ Length
deriving (Show, Lift)
deriving (Show, Eq, Lift)
tupling :: Iso' SrcSpan (Int, Int, Int, Int)
tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
(\ (a,b,c,d) -> SrcSpan a b c d)
srcspanLine, srcspanColumn, srcspanAbs, srcspanLen :: Lens' SrcSpan Int
srcspanLine = tupling . _1
srcspanColumn = tupling . _2
srcspanAbs = tupling . _3
srcspanLen = tupling . _4
srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen :: Lens' SrcSpan Int
srcSpanLine = tupling . _1
srcSpanColumn = tupling . _2
srcSpanAbs = tupling . _3
srcSpanLen = tupling . _4
-- | debug tool
nolo :: a -> Located a
nolo = Located (SrcSpan 0 0 0 0)
instance Semigroup SrcSpan where
-- multiple identities? what are the consequences of this...?
SrcSpan _ _ _ 0 <> SrcSpan l c a s = SrcSpan l c a s
SrcSpan l c a s <> SrcSpan _ _ _ 0 = SrcSpan l c a s
SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where
l = min la lb
c = min ca cb
a = min aa ab
s = case aa `compare` ab of
EQ -> max sa sb
LT -> max sa (ab + lb - aa)
GT -> max sb (aa + la - ab)
-- | A synonym for '(<<=)' with a tighter precedence and left-associativity for
-- use with '(<~>)' in a sort of, comonadic pseudo-applicative style.
(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b
(<<~) = (<<=)
infixl 4 <<~
-- | Similar to '(<*>)', but with a cokleisli arrow.
(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b
mc <~> ma = mc >>- \f -> ma =>> f
infixl 4 <~>
-- this is getting silly
(<#>) :: (Functor f) => f (a -> b) -> a -> f b
fab <#> a = fmap ($ a) fab
infixl 4 <#>
LT -> max sa (ab + sb - aa)
GT -> max sb (aa + sa - ab)
makePrisms ''Located