quox/lib/Quox/Loc.idr

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