{-|
Copyright   :  (C) 2019, Myrtle Software Ltd
License     :  BSD2 (see the file LICENSE)
Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>

Tools to convert a 'Term' into its "real" representation
-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}

module Clash.Core.TermLiteral
  ( TermLiteral
  , termToData
  , termToDataError
  , uncheckedTermToData
  ) where

import qualified Data.Text                       as Text
import           Data.Text                       (Text)
import           Data.Bifunctor                  (bimap)
import           Data.Either                     (lefts)
import           GHC.Natural
import           GHC.Stack

import           Clash.Core.Term                 (Term(Literal), collectArgs)
import           Clash.Core.Literal
import           Clash.Core.Pretty               (showPpr)

import           Clash.Core.TermLiteral.TH

-- | Tools to deal with literals encoded as a "Term".
class TermLiteral a where
  -- | Convert 'Term' to the constant it represents. Will return an error if
  -- (one of the subterms) fail to translate.
  termToData
    :: HasCallStack
    => Term
    -- ^ Term to convert
    -> Either Term a
    -- ^ 'Left' indicates a failure, containing the (sub)term that failed to
    -- translate. 'Right' indicates a success.

instance TermLiteral Term where
  termToData :: Term -> Either Term Term
termToData = Term -> Either Term Term
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure

instance TermLiteral String where
  termToData :: Term -> Either Term String
termToData (Term -> (Term, [Either Term Type])
collectArgs -> (_, [Left (Literal (StringLiteral s :: String
s))])) = String -> Either Term String
forall a b. b -> Either a b
Right String
s
  termToData t :: Term
t = Term -> Either Term String
forall a b. a -> Either a b
Left Term
t

instance TermLiteral Text where
  termToData :: Term -> Either Term Text
termToData t :: Term
t = String -> Text
Text.pack (String -> Text) -> Either Term String -> Either Term Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Either Term String
forall a. (TermLiteral a, HasCallStack) => Term -> Either Term a
termToData Term
t

instance TermLiteral Int where
  termToData :: Term -> Either Term Int
termToData (Term -> (Term, [Either Term Type])
collectArgs -> (_, [Left (Literal (IntLiteral n :: Integer
n))])) =
    Int -> Either Term Int
forall a b. b -> Either a b
Right (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n)
  termToData t :: Term
t = Term -> Either Term Int
forall a b. a -> Either a b
Left Term
t

instance TermLiteral Integer where
  termToData :: Term -> Either Term Integer
termToData (Term -> (Term, [Either Term Type])
collectArgs -> (_, [Left (Literal (IntegerLiteral n :: Integer
n))])) = Integer -> Either Term Integer
forall a b. b -> Either a b
Right Integer
n
  termToData t :: Term
t = Term -> Either Term Integer
forall a b. a -> Either a b
Left Term
t

instance TermLiteral Char where
  termToData :: Term -> Either Term Char
termToData (Term -> (Term, [Either Term Type])
collectArgs -> (_, [Left (Literal (CharLiteral c :: Char
c))])) = Char -> Either Term Char
forall a b. b -> Either a b
Right Char
c
  termToData t :: Term
t = Term -> Either Term Char
forall a b. a -> Either a b
Left Term
t

instance TermLiteral Natural where
  termToData :: Term -> Either Term Natural
termToData (Term -> (Term, [Either Term Type])
collectArgs -> (_, [Left (Literal (NaturalLiteral n :: Integer
n))])) =
    Natural -> Either Term Natural
forall a b. b -> Either a b
Right (Integer -> Natural
forall a. Num a => Integer -> a
fromInteger Integer
n)
  termToData t :: Term
t = Term -> Either Term Natural
forall a b. a -> Either a b
Left Term
t

instance (TermLiteral a, TermLiteral b) => TermLiteral (a, b) where
  termToData :: Term -> Either Term (a, b)
termToData (Term -> (Term, [Either Term Type])
collectArgs -> (_, [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts -> [a :: Term
a, b :: Term
b])) = do
    a
a' <- Term -> Either Term a
forall a. (TermLiteral a, HasCallStack) => Term -> Either Term a
termToData Term
a
    b
b' <- Term -> Either Term b
forall a. (TermLiteral a, HasCallStack) => Term -> Either Term a
termToData Term
b
    (a, b) -> Either Term (a, b)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (a
a', b
b')
  termToData t :: Term
t = Term -> Either Term (a, b)
forall a b. a -> Either a b
Left Term
t

instance TermLiteral a => TermLiteral (Maybe a) where
  termToData :: Term -> Either Term (Maybe a)
termToData = $(deriveTermToData ''Maybe)

instance TermLiteral Bool where
  termToData :: Term -> Either Term Bool
termToData = $(deriveTermToData ''Bool)

-- | Same as 'termToData', but returns printable error message if it couldn't
-- translate a term.
termToDataError :: TermLiteral a => Term -> Either String a
termToDataError :: Term -> Either String a
termToDataError term :: Term
term = (Term -> String) -> (a -> a) -> Either Term a -> Either String a
forall (p :: Type -> Type -> Type) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Term -> String
forall p. PrettyPrec p => p -> String
err a -> a
forall a. a -> a
id (Term -> Either Term a
forall a. (TermLiteral a, HasCallStack) => Term -> Either Term a
termToData Term
term)
 where
  err :: p -> String
err failedTerm :: p
failedTerm =
    "Failed to translate term to literal. Term that failed to translate:\n\n"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ p -> String
forall p. PrettyPrec p => p -> String
showPpr p
failedTerm String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n\nIn the full term:\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
term

-- | Same as 'termToData', but errors hard if it can't translate a given term
-- to data.
uncheckedTermToData :: TermLiteral a => Term -> a
uncheckedTermToData :: Term -> a
uncheckedTermToData = (String -> a) -> (a -> a) -> Either String a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> a
forall a. HasCallStack => String -> a
error a -> a
forall a. a -> a
id (Either String a -> a) -> (Term -> Either String a) -> Term -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Either String a
forall a. TermLiteral a => Term -> Either String a
termToDataError