quox/lib/Quox/Loc.idr

||| file locations
module Quox.Loc

import public Text.Bounded
import Data.SortedMap
import Derive.Prelude

%default total
%language ElabReflection

public export
FileName : Type
FileName = String

%runElab derive "Bounds" [Ord]

public export
data Loc_ = NoLoc | YesLoc FileName Bounds
%name Loc_ loc
%runElab derive "Loc_" [Eq, Ord, Show]


||| 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


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)