quox/lib/Quox/Loc.idr

153 lines
3.1 KiB
Idris
Raw Normal View History

||| file locations
module Quox.Loc
2023-10-19 22:53:20 -04:00
import Quox.PrettyValExtra
2023-05-01 21:06:25 -04:00
import public Text.Bounded
import Data.SortedMap
import Derive.Prelude
%default total
%language ElabReflection
public export
FileName : Type
FileName = String
2023-10-19 22:53:20 -04:00
%runElab derive "Bounds" [Ord, PrettyVal]
2023-05-01 21:06:25 -04:00
public export
2023-05-01 21:06:25 -04:00
data Loc_ = NoLoc | YesLoc FileName Bounds
%name Loc_ loc
2023-10-19 22:53:20 -04:00
%runElab derive "Loc_" [Eq, Ord, Show, PrettyVal]
2023-05-01 21:06:25 -04:00
||| a wrapper for locations which are always considered equal
public export
2023-05-01 21:06:25 -04:00
record Loc where
constructor L
val : Loc_
%name Loc loc
%runElab derive "Loc" [Show]
2023-05-01 21:06:25 -04:00
export %inline Eq Loc where _ == _ = True
export %inline Ord Loc where compare _ _ = EQ
public export %inline
noLoc : Loc
noLoc = L NoLoc
public export %inline
makeLoc : FileName -> Bounds -> Loc
2023-05-01 21:06:25 -04:00
makeLoc = L .: YesLoc
2023-10-19 22:53:20 -04:00
public export %inline
loc : FileName -> (sl, sc, el, ec : Int) -> Loc
loc file sl sc el ec = makeLoc file $ MkBounds sl sc el ec
export
PrettyVal Loc where
prettyVal (L NoLoc) = Con "noLoc" []
prettyVal (L (YesLoc file (MkBounds sl sc el ec))) =
Con "loc" [prettyVal file,
prettyVal sl, prettyVal sc,
prettyVal el, prettyVal ec]
export
2023-05-01 21:06:25 -04:00
onlyStart_ : Loc_ -> Loc_
onlyStart_ NoLoc = NoLoc
onlyStart_ (YesLoc fname (MkBounds sl sc _ _)) =
YesLoc fname $ MkBounds sl sc sl sc
export %inline
onlyStart : Loc -> Loc
2023-05-01 21:06:25 -04:00
onlyStart = {val $= onlyStart_}
export
2023-05-01 21:06:25 -04:00
onlyEnd_ : Loc_ -> Loc_
onlyEnd_ NoLoc = NoLoc
onlyEnd_ (YesLoc fname (MkBounds _ _ el ec)) =
YesLoc fname $ MkBounds el ec el ec
export %inline
onlyEnd : Loc -> Loc
2023-05-01 21:06:25 -04:00
onlyEnd = {val $= onlyEnd_}
export
2023-05-01 21:06:25 -04:00
extend_ : Loc_ -> Bounds -> Loc_
extend_ NoLoc _ = NoLoc
extend_ (YesLoc fname (MkBounds sl1 sc1 el1 ec1)) (MkBounds sl2 sc2 el2 ec2) =
let (sl, sc) = (sl1, sc1) `min` (sl2, sc2)
(el, ec) = (el1, ec1) `max` (el2, ec2)
in
2023-05-01 21:06:25 -04:00
YesLoc fname $ MkBounds sl sc el ec
export
extend : Loc -> Bounds -> Loc
extend l b = L $ extend_ l.val b
export
extend' : Loc -> Maybe Bounds -> Loc
extend' l b = maybe l (extend l) b
2023-05-01 21:06:25 -04:00
namespace Loc_
export
(.bounds) : Loc_ -> Maybe Bounds
(YesLoc _ b).bounds = Just b
(NoLoc).bounds = Nothing
namespace Loc
export
(.bounds) : Loc -> Maybe Bounds
l.bounds = l.val.bounds
export %inline
extendL : Loc -> Loc -> Loc
extendL l1 l2 = l1 `extend'` l2.bounds
infixr 1 `or_`, `or`
export %inline
or_ : Loc_ -> Loc_ -> Loc_
or_ l1@(YesLoc {}) _ = l1
or_ NoLoc l2 = l2
export %inline
or : Loc -> Loc -> Loc
or (L l1) (L l2) = L $ l1 `or_` l2
2023-11-27 15:01:36 -05:00
export %inline
extendOr : Loc -> Loc -> Loc
extendOr l1 l2 = (l1 `extendL` l2) `or` l2
2023-05-01 21:06:25 -04:00
public export
interface Located a where (.loc) : a -> Loc
2023-05-01 21:06:25 -04:00
public export
0 Located1 : (a -> Type) -> Type
Located1 f = forall x. Located (f x)
2023-11-27 15:01:36 -05:00
public export
0 Located2 : (a -> b -> Type) -> Type
Located2 f = forall x, y. Located (f x y)
2023-05-01 21:06:25 -04:00
public export
interface Located a => Relocatable a where setLoc : Loc -> a -> a
public export
0 Relocatable1 : (a -> Type) -> Type
Relocatable1 f = forall x. Relocatable (f x)
2023-11-27 15:01:36 -05:00
public export
0 Relocatable2 : (a -> b -> Type) -> Type
Relocatable2 f = forall x, y. Relocatable (f x y)
export
locs : Located a => Foldable t => t a -> Loc
locs = foldl (\loc, y => loc `extendOr` y.loc) noLoc