{-# OPTIONS_GHC -Wunused-imports #-}

-- | Converts case matches on literals to if cascades with equality comparisons.
module Agda.Compiler.Treeless.EliminateLiteralPatterns where

import Data.Maybe

import Agda.Syntax.Treeless
import Agda.Syntax.Literal

import Agda.TypeChecking.Monad
import Agda.TypeChecking.Primitive

import Agda.Utils.Impossible


eliminateLiteralPatterns :: TTerm -> TCM TTerm
eliminateLiteralPatterns :: TTerm -> TCM TTerm
eliminateLiteralPatterns TTerm
t = do
  kit <- Maybe QName -> Maybe QName -> BuiltinKit
BuiltinKit (Maybe QName -> Maybe QName -> BuiltinKit)
-> TCMT IO (Maybe QName) -> TCMT IO (Maybe QName -> BuiltinKit)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BuiltinId -> TCMT IO (Maybe QName)
forall (m :: * -> *).
(HasBuiltins m, MonadReduce m) =>
BuiltinId -> m (Maybe QName)
getBuiltinName BuiltinId
builtinNat TCMT IO (Maybe QName -> BuiltinKit)
-> TCMT IO (Maybe QName) -> TCMT IO BuiltinKit
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BuiltinId -> TCMT IO (Maybe QName)
forall (m :: * -> *).
(HasBuiltins m, MonadReduce m) =>
BuiltinId -> m (Maybe QName)
getBuiltinName BuiltinId
builtinInteger
  return $ transform kit t

data BuiltinKit = BuiltinKit
  { BuiltinKit -> Maybe QName
nat :: Maybe QName
  , BuiltinKit -> Maybe QName
int :: Maybe QName
  }

transform :: BuiltinKit -> TTerm -> TTerm
transform :: BuiltinKit -> TTerm -> TTerm
transform BuiltinKit
kit = TTerm -> TTerm
tr
  where
    tr :: TTerm -> TTerm
    tr :: TTerm -> TTerm
tr = \case
      TCase Int
sc CaseInfo
t TTerm
def [TAlt]
alts | CaseInfo -> CaseType
caseType CaseInfo
t CaseType -> [CaseType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CaseType
CTChar, CaseType
CTString, CaseType
CTQName, CaseType
CTNat, CaseType
CTInt, CaseType
CTFloat] ->
        (TAlt -> TTerm -> TTerm) -> TTerm -> [TAlt] -> TTerm
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TAlt -> TTerm -> TTerm
litAlt (TTerm -> TTerm
tr TTerm
def) [TAlt]
alts
        where
          litAlt :: TAlt -> TTerm -> TTerm
          litAlt :: TAlt -> TTerm -> TTerm
litAlt (TALit Literal
l TTerm
body) TTerm
cont =
            TTerm -> TTerm -> TTerm -> TTerm
tIfThenElse
              (TPrim -> TTerm -> TTerm -> TTerm
tOp (Literal -> TPrim
eqFromLit Literal
l) (Literal -> TTerm
TLit Literal
l) (Int -> TTerm
TVar Int
sc))
              (TTerm -> TTerm
tr TTerm
body)
              TTerm
cont
          litAlt TAlt
_ TTerm
_ = TTerm
forall a. HasCallStack => a
__IMPOSSIBLE__
      TCase Int
sc t :: CaseInfo
t@CaseInfo{caseType :: CaseInfo -> CaseType
caseType = CTData QName
dt} TTerm
def [TAlt]
alts ->
        Int -> CaseInfo -> TTerm -> [TAlt] -> TTerm
TCase Int
sc CaseInfo
t (TTerm -> TTerm
tr TTerm
def) ((TAlt -> TAlt) -> [TAlt] -> [TAlt]
forall a b. (a -> b) -> [a] -> [b]
map TAlt -> TAlt
trAlt [TAlt]
alts)
        where
          trAlt :: TAlt -> TAlt
trAlt = \case
            TAGuard TTerm
g TTerm
b -> TTerm -> TTerm -> TAlt
TAGuard (TTerm -> TTerm
tr TTerm
g) (TTerm -> TTerm
tr TTerm
b)
            TACon QName
q Int
a TTerm
b -> QName -> Int -> TTerm -> TAlt
TACon QName
q Int
a (TTerm -> TTerm
tr TTerm
b)
            TALit Literal
l TTerm
b   -> Literal -> TTerm -> TAlt
TALit Literal
l (TTerm -> TTerm
tr TTerm
b)
      TCase Int
_ CaseInfo
_ TTerm
_ [TAlt]
_ -> TTerm
forall a. HasCallStack => a
__IMPOSSIBLE__

      t :: TTerm
t@TVar{}    -> TTerm
t
      t :: TTerm
t@TDef{}    -> TTerm
t
      t :: TTerm
t@TCon{}    -> TTerm
t
      t :: TTerm
t@TPrim{}   -> TTerm
t
      t :: TTerm
t@TLit{}    -> TTerm
t
      t :: TTerm
t@TUnit{}   -> TTerm
t
      t :: TTerm
t@TSort{}   -> TTerm
t
      t :: TTerm
t@TErased{} -> TTerm
t
      t :: TTerm
t@TError{}  -> TTerm
t

      TCoerce TTerm
a               -> TTerm -> TTerm
TCoerce (TTerm -> TTerm
tr TTerm
a)
      TLam TTerm
b                  -> TTerm -> TTerm
TLam (TTerm -> TTerm
tr TTerm
b)
      TApp TTerm
a Args
bs               -> TTerm -> Args -> TTerm
TApp (TTerm -> TTerm
tr TTerm
a) ((TTerm -> TTerm) -> Args -> Args
forall a b. (a -> b) -> [a] -> [b]
map TTerm -> TTerm
tr Args
bs)
      TLet TTerm
e TTerm
b                -> TTerm -> TTerm -> TTerm
TLet (TTerm -> TTerm
tr TTerm
e) (TTerm -> TTerm
tr TTerm
b)

    -- TODO:: Defined but not used
    isCaseOn :: CaseType -> [BuiltinKit -> Maybe QName] -> Bool
isCaseOn (CTData QName
dt) [BuiltinKit -> Maybe QName]
xs = QName
dt QName -> [QName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((BuiltinKit -> Maybe QName) -> Maybe QName)
-> [BuiltinKit -> Maybe QName] -> [QName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((BuiltinKit -> Maybe QName) -> BuiltinKit -> Maybe QName
forall a b. (a -> b) -> a -> b
$ BuiltinKit
kit) [BuiltinKit -> Maybe QName]
xs
    isCaseOn CaseType
_ [BuiltinKit -> Maybe QName]
_ = Bool
False

    eqFromLit :: Literal -> TPrim
    eqFromLit :: Literal -> TPrim
eqFromLit = \case
      LitNat Integer
_     -> TPrim
PEqI
      LitFloat Double
_   -> TPrim
PEqF
      LitString Text
_  -> TPrim
PEqS
      LitChar Char
_    -> TPrim
PEqC
      LitQName QName
_   -> TPrim
PEqQ
      Literal
_ -> TPrim
forall a. HasCallStack => a
__IMPOSSIBLE__