{-# OPTIONS_GHC -Wunused-imports #-}
{-# OPTIONS_GHC -Wunused-matches #-}
{-# OPTIONS_GHC -Wunused-binds #-}

module Mikan.Syntax.Literal where

import Control.DeepSeq
import Data.Char

import Data.Text.Short (ShortText)
import Data.Text.Short qualified as TS

import Mikan.Syntax.Position
import Mikan.Syntax.Common ( Ranged, MetaId )
import Mikan.Syntax.Abstract.Name ( QName )
import Mikan.Syntax.TopLevelModuleName.Boot ( TopLevelModuleName' )
import Mikan.Utils.Float ( doubleDenotEq, doubleDenotOrd )
import Mikan.Syntax.Common.Pretty

type RLiteral = Ranged Literal
data Literal
  = LitNat    !Integer
  | LitFloat  !Double
  | LitString !ShortText
  | LitChar   !Char
  | LitQName  !QName
  | LitMeta   !(TopLevelModuleName' Range) !MetaId
  deriving Int -> Literal -> ShowS
[Literal] -> ShowS
Literal -> String
(Int -> Literal -> ShowS)
-> (Literal -> String) -> ([Literal] -> ShowS) -> Show Literal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Literal -> ShowS
showsPrec :: Int -> Literal -> ShowS
$cshow :: Literal -> String
show :: Literal -> String
$cshowList :: [Literal] -> ShowS
showList :: [Literal] -> ShowS
Show

instance Pretty Literal where
    pretty :: Literal -> Doc
pretty (LitNat Integer
n)     = Doc -> Doc
hlNumber (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Integer -> Doc
forall a. Pretty a => a -> Doc
pretty Integer
n
    pretty (LitFloat Double
d)   = Doc -> Doc
hlNumber (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Double -> Doc
forall a. Pretty a => a -> Doc
pretty Double
d
    pretty (LitString ShortText
s)  = Doc -> Doc
hlString (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
forall a. String -> Doc a
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ ShortText -> ShowS
showText ShortText
s String
""
    pretty (LitChar Char
c)    = Doc -> Doc
hlString (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
forall a. String -> Doc a
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> ShowS
showChar' Char
c String
"'"
    pretty (LitQName QName
x)   = QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
x
    pretty (LitMeta TopLevelModuleName' Range
_ MetaId
x)  = MetaId -> Doc
forall a. Pretty a => a -> Doc
pretty MetaId
x

showText :: ShortText -> ShowS
showText :: ShortText -> ShowS
showText ShortText
s = String -> ShowS
showString String
"\""
           ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> ShowS -> ShowS) -> ShowS -> ShortText -> ShowS
forall a. (Char -> a -> a) -> a -> ShortText -> a
TS.foldr (\ Char
c -> (Char -> ShowS
showChar' Char
c ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)) ShowS
forall a. a -> a
id ShortText
s
           ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"\""

showChar' :: Char -> ShowS
showChar' :: Char -> ShowS
showChar' Char
'"'   = String -> ShowS
showString String
"\\\""
showChar' Char
c
    | Char -> Bool
escapeMe Char
c = Char -> ShowS
showLitChar Char
c
    | Bool
otherwise  = String -> ShowS
showString [Char
c]
    where
        escapeMe :: Char -> Bool
escapeMe Char
c = Bool -> Bool
not (Char -> Bool
isPrint Char
c) Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\'

instance Eq Literal where
  LitNat Integer
n    == :: Literal -> Literal -> Bool
== LitNat Integer
m    = Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
m
  LitFloat Double
x  == LitFloat Double
y  = Double -> Double -> Bool
doubleDenotEq Double
x Double
y
  LitString ShortText
s == LitString ShortText
t = ShortText
s ShortText -> ShortText -> Bool
forall a. Eq a => a -> a -> Bool
== ShortText
t
  LitChar Char
c   == LitChar Char
d   = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
d
  LitQName QName
x  == LitQName QName
y  = QName
x QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
y
  LitMeta TopLevelModuleName' Range
f MetaId
x == LitMeta TopLevelModuleName' Range
g MetaId
y = (TopLevelModuleName' Range
f, MetaId
x) (TopLevelModuleName' Range, MetaId)
-> (TopLevelModuleName' Range, MetaId) -> Bool
forall a. Eq a => a -> a -> Bool
== (TopLevelModuleName' Range
g, MetaId
y)
  Literal
_           == Literal
_             = Bool
False

instance Ord Literal where
  LitNat Integer
n    compare :: Literal -> Literal -> Ordering
`compare` LitNat Integer
m    = Integer
n Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Integer
m
  LitFloat Double
x  `compare` LitFloat Double
y  = Double -> Double -> Ordering
doubleDenotOrd Double
x Double
y
  LitString ShortText
s `compare` LitString ShortText
t = ShortText
s ShortText -> ShortText -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` ShortText
t
  LitChar Char
c   `compare` LitChar Char
d   = Char
c Char -> Char -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Char
d
  LitQName QName
x  `compare` LitQName QName
y  = QName
x QName -> QName -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` QName
y
  LitMeta TopLevelModuleName' Range
f MetaId
x `compare` LitMeta TopLevelModuleName' Range
g MetaId
y = (TopLevelModuleName' Range
f, MetaId
x) (TopLevelModuleName' Range, MetaId)
-> (TopLevelModuleName' Range, MetaId) -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (TopLevelModuleName' Range
g, MetaId
y)
  compare LitNat{}    Literal
_ = Ordering
LT
  compare Literal
_ LitNat{}    = Ordering
GT
  compare LitFloat{}  Literal
_ = Ordering
LT
  compare Literal
_ LitFloat{}  = Ordering
GT
  compare LitString{} Literal
_ = Ordering
LT
  compare Literal
_ LitString{} = Ordering
GT
  compare LitChar{} Literal
_   = Ordering
LT
  compare Literal
_ LitChar{}   = Ordering
GT
  compare LitQName{} Literal
_  = Ordering
LT
  compare Literal
_ LitQName{}  = Ordering
GT
  -- compare LitMeta{} _   = LT
  -- compare _ LitMeta{}   = GT

instance KillRange Literal where
  killRange :: Literal -> Literal
killRange (LitNat    Integer
x) = Integer -> Literal
LitNat    Integer
x
  killRange (LitFloat  Double
x) = Double -> Literal
LitFloat  Double
x
  killRange (LitString ShortText
x) = ShortText -> Literal
LitString ShortText
x
  killRange (LitChar   Char
x) = Char -> Literal
LitChar   Char
x
  killRange (LitQName  QName
x) = (QName -> Literal) -> QName -> Literal
forall t (b :: Bool).
(KILLRANGE t b, IsBase t ~ b, All KillRange (Domains t)) =>
t -> t
killRangeN QName -> Literal
LitQName QName
x
  killRange (LitMeta TopLevelModuleName' Range
m MetaId
x) = TopLevelModuleName' Range -> MetaId -> Literal
LitMeta (KillRangeT (TopLevelModuleName' Range)
forall a. KillRange a => KillRangeT a
killRange TopLevelModuleName' Range
m) MetaId
x

-- | Ranges are not forced.

instance NFData Literal where
  rnf :: Literal -> ()
rnf (LitNat Integer
_     ) = ()
  rnf (LitFloat Double
_   ) = ()
  rnf (LitString ShortText
_  ) = ()
  rnf (LitChar Char
_    ) = ()
  rnf (LitQName QName
a   ) = QName -> ()
forall a. NFData a => a -> ()
rnf QName
a
  rnf (LitMeta TopLevelModuleName' Range
m MetaId
_  ) = TopLevelModuleName' Range -> ()
forall a. NFData a => a -> ()
rnf TopLevelModuleName' Range
m