quox/lib/Quox/Loc.idr

152 lines
3.1 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
export %inline
extendOr : Loc -> Loc -> Loc
extendOr l1 l2 = (l1 `extendL` l2) `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
0 Located2 : (a -> b -> Type) -> Type
Located2 f = forall x, y. Located (f x y)
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)
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