134 lines
2.7 KiB
Idris
134 lines
2.7 KiB
Idris
||| file locations
|
|
module Quox.Loc
|
|
|
|
import Quox.PrettyValExtra
|
|
import public Text.Bounded
|
|
import Data.SortedMap
|
|
import Derive.Prelude
|
|
|
|
%default total
|
|
%language ElabReflection
|
|
|
|
public export
|
|
FileName : Type
|
|
FileName = String
|
|
|
|
%runElab derive "Bounds" [Ord, PrettyVal]
|
|
|
|
public export
|
|
data Loc_ = NoLoc | YesLoc FileName Bounds
|
|
%name Loc_ loc
|
|
%runElab derive "Loc_" [Eq, Ord, Show, PrettyVal]
|
|
|
|
|
|
||| a wrapper for locations which are always considered equal
|
|
public export
|
|
record Loc where
|
|
constructor L
|
|
val : Loc_
|
|
%name Loc loc
|
|
%runElab derive "Loc" [Show]
|
|
|
|
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
|
|
makeLoc = L .: YesLoc
|
|
|
|
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
|
|
onlyStart_ : Loc_ -> Loc_
|
|
onlyStart_ NoLoc = NoLoc
|
|
onlyStart_ (YesLoc fname (MkBounds sl sc _ _)) =
|
|
YesLoc fname $ MkBounds sl sc sl sc
|
|
|
|
export %inline
|
|
onlyStart : Loc -> Loc
|
|
onlyStart = {val $= onlyStart_}
|
|
|
|
export
|
|
onlyEnd_ : Loc_ -> Loc_
|
|
onlyEnd_ NoLoc = NoLoc
|
|
onlyEnd_ (YesLoc fname (MkBounds _ _ el ec)) =
|
|
YesLoc fname $ MkBounds el ec el ec
|
|
|
|
export %inline
|
|
onlyEnd : Loc -> Loc
|
|
onlyEnd = {val $= onlyEnd_}
|
|
|
|
|
|
export
|
|
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
|
|
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
|
|
|
|
|
|
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
|
|
|
|
|
|
public export
|
|
interface Located a where (.loc) : a -> Loc
|
|
|
|
public export
|
|
0 Located1 : (a -> Type) -> Type
|
|
Located1 f = forall x. Located (f x)
|
|
|
|
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)
|