quox/lib/Quox/Name.idr

module Quox.Name

import Quox.Loc
import Quox.CharExtra
import public Data.SnocList
import Data.List
import Control.Eff
import Text.Lexer
import Derive.Prelude

%hide TT.Name

%default total
%language ElabReflection


public export
NameSuf : Type
NameSuf = Nat

public export
data BaseName
= UN String         -- user-given name
| MN String NameSuf -- machine-generated name
| Unused            -- "_"
%runElab derive "BaseName" [Eq, Ord]

export
baseStr : BaseName -> String
baseStr (UN x)   = x
baseStr (MN x i) = "\{x}#\{show i}"
baseStr Unused   = "_"

export Show BaseName where show = baseStr
export FromString BaseName where fromString = UN


public export
Mods : Type
Mods = SnocList String


public export
record Name where
  constructor MakeName
  mods : Mods
  base : BaseName
%runElab derive "Name" [Eq, Ord]

public export %inline
unq : BaseName -> Name
unq = MakeName [<]

||| add some namespaces to the beginning of a name
public export %inline
addMods : Mods -> Name -> Name
addMods ms = {mods $= (ms <+>)}


public export
PBaseName : Type
PBaseName = String

public export
record PName where
  constructor MakePName
  mods : Mods
  base : PBaseName
%runElab derive "PName" [Eq, Ord]

export %inline
fromPName : PName -> Name
fromPName p = MakeName p.mods $ UN p.base

export %inline
toPName : Name -> PName
toPName p = MakePName p.mods $ baseStr p.base

export %inline
fromPBaseName : PBaseName -> Name
fromPBaseName = MakeName [<] . UN

export
Show PName where
  show (MakePName mods base) = concat $ intersperse "." $ toList $ mods :< base

export Show Name where show = show . toPName

export FromString PName where fromString = MakePName [<]

export FromString Name where fromString = fromPBaseName


public export
record BindName where
  constructor BN
  name : BaseName
  loc_ : Loc
%runElab derive "BindName" [Eq, Ord, Show]

export Located BindName where n.loc = n.loc_
export Relocatable BindName where setLoc loc (BN x _) = BN x loc


export
toDotsP : PName -> String
toDotsP x = fastConcat $ cast $ map (<+> ".") x.mods :< x.base

export
toDots : Name -> String
toDots x = fastConcat $ cast $ map (<+> ".") x.mods :< baseStr x.base

export
fromListP : List1 String -> PName
fromListP (x ::: xs) = go [<] x xs where
  go : SnocList String -> String -> List String -> PName
  go mods x []        = MakePName mods x
  go mods x (y :: ys) = go (mods :< x) y ys

export %inline
fromList : List1 String -> Name
fromList = fromPName . fromListP


export
syntaxChars : List Char
syntaxChars = ['(', ')', '[', ']', '{', '}', '"', '\'', ',', '.', ';']

export
isSymStart, isSymCont : Char -> Bool
isSymStart c = not (c `elem` syntaxChars) && isSymChar c
isSymCont  c = c == '\'' || isSymStart c

export
idStart, idCont, idEnd, idContEnd : Lexer
idStart   = pred isIdStart
idCont    = pred isIdCont
idEnd     = pred $ \c => c `elem` unpack "?!#"
idContEnd = idCont <|> idEnd

export
symStart, symCont : Lexer
symStart  = pred isSymStart
symCont   = pred isSymCont

export
baseName : Lexer
baseName = idStart <+> many idCont <+> many idEnd
       <|> symStart <+> many symCont

export
name : Lexer
name = baseName <+> many (is '.' <+> baseName)


export
isName : String -> Bool
isName str =
  case scan name [] (unpack str) of
    Just (_, []) => True
    _            => False


public export
data GenTag = GEN

public export
NameGen : Type -> Type
NameGen = StateL GEN NameSuf

export
runNameGenWith : Has NameGen fs =>
                 NameSuf -> Eff fs a -> Eff (fs - NameGen) (a, NameSuf)
runNameGenWith = runStateAt GEN

export
runNameGen : Has NameGen fs => Eff fs a -> Eff (fs - NameGen) a
runNameGen = map fst . runNameGenWith 0

||| generate a fresh name with the given base
export
mn : Has NameGen fs => PBaseName -> Eff fs BaseName
mn base = do
  i <- getAt GEN
  modifyAt GEN S
  pure $ MN base i

||| generate a fresh binding name with the given base and
||| (optionally) location `loc`
export
mnb : Has NameGen fs =>
      PBaseName -> {default noLoc loc : Loc} -> Eff fs BindName
mnb base = pure $ BN !(mn base) loc

export
fresh : Has NameGen fs => BindName -> Eff fs BindName
fresh (BN (UN str)   loc) = mnb str {loc}
fresh (BN (MN str k) loc) = mnb str {loc}
fresh (BN Unused     loc) = mnb "x" {loc}