{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ViewPatterns #-}
module Types
    ( Env, GlobalEnv, LocalEnv
    , Arity (..)
    , InTail
    , Builtin
    , Primitive (..)
    , Macro (..)
    , Val (..), Symbol, Port(..)
    , RealNumber (..), Number (..)
    , symbolName, symbolAsString
    , Ref
    , LispErr (..), ExceptionCont (..)
    , ThrowsError
    , IOThrowsError
    , extractValue
    , isTerminationError
    , liftEither
   -- , runIOThrows
    , EM (..), emCont
    , EvalState (..), dynPoint, currentHandlers
    , StackFrame (..)
    , DynamicEnv(DynamicEnv)
    , ExceptionHandler
    , DynamicPoint (..)
    , Opts
   -- , TraceType
    , liftIOThrows
    ) where

import Control.Monad.Cont
    ( (<=<),
      MonadIO(..),
      MonadCont(..),
      ContT(ContT),
      cont,
      runCont,
      Cont )
import Control.Monad.Except           ( ExceptT, MonadError(..), liftEither
                                      , runExceptT )
import Control.Monad.State.Lazy       ( MonadState(get, put), gets, modify )
import Data.Complex                   ( Complex(..) )
import Data.HashMap.Strict            ( HashMap )
import Data.IORef                     ( IORef, readIORef, writeIORef )
import Data.Ratio                     ( (%), denominator, numerator )
import Data.Text                      ( Text, unpack )
import qualified Data.Text           as T
import qualified Data.Vector         as V
import qualified Data.Vector.Mutable as V
import qualified Data.Vector.Unboxed as U
import           Data.Word                      ( Word8 )
import           System.IO                      ( Handle )

import Options

{- Note: [IORefs in Envs]

Vals already have a notion of being "primitive" or a "pointer".
So why do 'Env's store 'IORef's? We want to be able to
_duplicate environments_ (for the purposes of capturing them in closures)
and be sure that the copied environments reflect changes in the originals.

It's not impossible that I'm completely off-base here and duplicating the
environments is not actually worth it in terms of performance. A duplicated
environment is always smaller than the original, since it flattens the
scope structure and removes shadowed bindings. However, That _usually_
isn't significantly smaller, and currently we pay an extra dereference for
every single name lookup. Low-hanging fruit?
-}
type Env = IORef (HashMap Symbol (IORef Val))
type GlobalEnv = Env
type LocalEnv  = [Env] -- ^ stack of environments forms local env
type Ref = IORef

-- * Function types and components
--type Arity = Int
data Arity
  = Exactly Int
  | AtLeast Int
  | Between Int Int
  deriving (Eq, Ord)
type InTail = Bool
type Builtin = [Val] -> EM Val
data Primitive = Prim Symbol Arity Builtin
-- The additional 'InTail' flag is necessary for macros like 'begin'
-- and 'if' which need to use a different 'eval' behavior if they are
-- in tail position. We do global CPS anyway (EM monad) but this information
-- is needed to maintain the debug stack.
data Macro = Macro Arity (InTail -> Builtin)

-- | Scheme values.
--
-- Some Scheme values can be either mutable or immutable. These are strings,
-- lists, and vectors. The immutable variant begins with I, where applicable.
--
-- The mutable data structures are interpreter-only;
-- the parser cannot construct them.
--
-- Invariant: All objects contained in an IPair or IVector are immutable.
--   Note that this is implicitly transitive.
data Val
  = Symbol Symbol

  | Number !Number

  | String !(Ref Text)
  | IString Text
  | Char Char
  | Bool Bool

  | Primitive Arity Builtin Symbol
  | PrimMacro Arity (InTail -> Builtin) Symbol
  | Continuation DynamicPoint (Val -> EM Val)
  | Closure
     { params :: [Symbol]
     , vararg :: Maybe Symbol
     , body   :: [Val]
     , cloEnv :: LocalEnv
     , name   :: Maybe Symbol
     }

  | Port Port

  | Nil
  | Pair !(Ref Val) !(Ref Val)
  -- this can't be made strict, else, attempting to construct an
  -- cyclic static data structure containing a pair /anywhere in the structure/
  -- would hang!
  | IPair Val Val

  | Vector  !(V.IOVector Val)
  | IVector !(V.Vector Val)
  | IByteVector !(U.Vector Word8)

   -- if we ever add a way to register writers for custom
   -- record types, then error objects should become a
   -- standard library record type and this should go.
  | Error Text [Val]
  | Exception LispErr
  | EOF

    -- | Used to identify when a recursive binding refers to itself during
    -- initialization, which is an error.
    -- If 'unspecified' or 'void' are added in the future, they should be
    -- distinct from this.
  | Undefined
    -- | Implements multiple values for the purposes of call-with-values.
    -- If one of these ever appears somewhere that it shouldn't, it will
    -- eventually get sent through `eval`, which will raise an error.
  | MultipleValues [Val]

type Symbol = Text

symbolName :: Symbol -> Text
symbolName (T.uncons -> Just ('~', name)) = name
symbolName (T.uncons -> Just ('&', name)) =
  let pieces = T.splitOn "~" name
      -- pieces are some number of components from the name
      -- if it contained tildes, followed by two components
      -- which are the unique identifiers.
  in T.intercalate "~" $ reverse $ drop 2 $ reverse pieces
symbolName primName = primName

-- | Converts a symbol to its human-readable name as a string.
-- Mostly useful for Show/write and in 'panic' messages.
symbolAsString :: Symbol -> String
symbolAsString = unpack . symbolName

data Port
  = HandlePort !Handle
  -- consuming is permanent, as indexing characters
  -- into a Unicode stream is necessarily O(n)
  -- so supporting seeking is horribly slow.
  -- When closed, the IORef is cleared so that the
  -- text can eventually be freed.
  | InputTextPort !(IORef Text) !(IORef Bool) -- open?
  -- collect chunks, which will later be collected
  -- by 'T.concat'. The chunks are stored in LIFO order.
  -- When closed, the IORef is cleared so that the
  -- list can be reclaimed by GC.
  | OutputTextPort !(IORef [Text]) !(IORef Bool) -- open?
  deriving (Eq)

-- | Scheme numbers. Note that there is no Ord Number instance;
-- complex numbers are not orderable and Scheme comparisons of
-- complex numbers are errors.
data Number
  = Real {-# UNPACK #-}!RealNumber
  | Complex {-# UNPACK #-}!(Complex RealNumber)

data RealNumber
  = Bignum {-# UNPACK #-}!Integer
  | Flonum {-# UNPACK #-}!Double
  | Ratnum {-# UNPACK #-}!Rational

-- | This is equality in the sense of Scheme '='.
instance Eq RealNumber where
  Flonum f == Flonum g = f == g
  Flonum f == bigOrRat = not (isInfinite f) && r1 == r2
    -- note that we make the fp number exact instead of making the
    -- exact number fp. This is critical. An example from the R7RS
    -- paper is: let big be (exp 2 1000). Assume big is exact and
    -- that inexact numbers are IEEE doubles [they are]. Then
    -- (= (inexact big) (+ big 1)) should be #f, but if inexact
    -- conversion is used, it will be #t.
    where r1 = toRational f
          r2 = case bigOrRat of
            Bignum i -> i % 1
            Ratnum r -> r
            Flonum{} -> error "(==)@RealNumber: impossible flonum"
  bigOrRat == n@Flonum{} = n == bigOrRat
  Bignum i == Bignum j = i == j
  Bignum i == Ratnum r = i % 1 == r
  Ratnum r == Bignum i = r == i % 1
  Ratnum r == Ratnum s = r == s

instance Eq Number where
  Real a == Real b = a == b
  Real a == Complex (r :+ i) = a == r && i == Bignum 0
  Complex (r :+ i) == Real b = r == b && i == Bignum 0
  Complex (a :+ b) == Complex (x :+ y) = a == x && b == y

instance Show RealNumber where
  show (Bignum i) = show i
  show (Flonum f)
    | isInfinite f = sign : "inf.0"
    | isNaN f      = "+nan.0"
    | otherwise    = show f
    where sign = if f < 0 then '-' else '+'
  show (Ratnum r)
    | denominator r == 1 = show (numerator r)
    | otherwise = show (numerator r) ++ "/" ++ show (denominator r)

-- | Doesn't compare mutable things; most likely you want
--
-- (1) 'eqSSH':    referential equality
-- (2) 'eqvSSH':   value equality for atoms, otherwise referential
-- (3) 'equalSSH': structural equality
eqVal :: Val -> Val -> Bool
eqVal (Symbol s) (Symbol s') = s == s'
eqVal (Number n) (Number n') = n == n'
eqVal (IString s) (IString s') = s == s'
eqVal (Char c) (Char c') = c == c'
eqVal (Bool b) (Bool b') = b == b'
eqVal (IVector v) (IVector v') = v == v'
eqVal (Port p) (Port p') = p == p'
eqVal (Primitive _ _ n) (Primitive _ _ n') = n == n'
eqVal Continuation{} _ = False -- perhaps it's possible to give continuations
eqVal _ Continuation{} = False -- unique identifiers to make this work.
                               -- However... why? 'eq?' works fine by just
                               -- comparing their StableNames and anything we
                               -- might want to test can be tested with 'eq?'.
eqVal (Closure p v b _ n) (Closure p' v' b' _ n') =
    and [ p == p'
        , v == v'
        , b == b'
        , n == n'
        ]
eqVal Nil Nil = True
eqVal p@IPair{} q@IPair{} =
    fromList p == fromList q
  where
    fromList :: Val -> ([Val], Val)
    fromList (IPair c d) =
      first (c:) $ fromList d
    fromList obj = ([], obj)

    first f (a, b) = (f a, b)
eqVal _ _ = False

-- Eq Val is defined here so that 'LispErr' can derive 'Eq'.
-- But it might be more sane to just not allow pure comparisons of
-- 'Val's or 'LispErr's. I think (?) it's only useful in tests
-- (and I'm not even sure that the tests use it anymore).

-- | Compares closures by shape rather than only by name/location tag.
-- Can't compare continuations (because they currently aren't tagged).
-- Can't compare mutable pairs (use 'valsSameShape' instead).
instance Eq Val where (==) = eqVal

-- | Only so that LispErr can derive Eq.
newtype ExceptionCont = EC (Val -> EM Val)
data LispErr = NumArgs Arity [Val]
             | TypeMismatch String Val
             | Parser String
             | BadSpecialForm Val
             | NotFunction String Val
             | UnboundVar String Symbol
             | EvaluateDuringInit Symbol
             | SetImmutable String -- type name
             | CircularList
             | EmptyBody

             | Condition (Maybe ExceptionCont) -- ^ continuable?
                         Val

             | Default String
             | Quit

-- This is not derived _purely_ so that we can compare
-- symbols by symbolName in two cases. Annoying.
instance Eq LispErr where
  NumArgs a1 vs1        == NumArgs a2 vs2        = a1 == a2 && vs1 == vs2
  TypeMismatch s1 v1    == TypeMismatch s2 v2    = s1 == s2 && v1 == v2
  Parser s1             == Parser s2             = s1 == s2
  BadSpecialForm v1     == BadSpecialForm v2     = v1 == v2
  NotFunction s1 v1     == NotFunction s2 v2     = s1 == s2 && v1 == v2
  UnboundVar s1 n1      == UnboundVar s2 n2      = s1 == s2 && symbolName n1 == symbolName n2
  EvaluateDuringInit n1 == EvaluateDuringInit n2 = symbolName n1 == symbolName n2
  SetImmutable s1       == SetImmutable s2       = s1 == s2
  CircularList          == CircularList          = True
  EmptyBody             == EmptyBody             = True
  Condition _ v1        == Condition _ v2        = v1 == v2
  Default s1            == Default s2            = s1 == s2
  Quit == Quit = True
  _ == _ = False

instance Eq ExceptionCont where
  EC _ == EC _ = True -- let the comparison be by everything else

type ThrowsError = Either LispErr

--trapError :: ThrowsError String -> ThrowsError String
--trapError action = catchError action (return . show)

extractValue :: ThrowsError a -> a
extractValue (Right val) = val
extractValue Left{} = error "extractValue: Left"

isTerminationError :: LispErr -> Bool
isTerminationError Quit = True
isTerminationError _    = False

type IOThrowsError = ExceptT LispErr IO

--runIOThrows :: IOThrowsError String -> IO String
--runIOThrows action = extractValue . trapError <$> runExceptT action

{- Note: [EM return types]
Ideally, we'd like EM to be able to return any type, instead of just 'Val'.
MTL's Cont type handles this with a type variable; 'Cont r a'.

I tried lots of variations on EM that didn't require putting an 'r' type
everywhere. I couldn't make it work. The most promising attempt was
type EMCont r = EvalState -> IO (Either LispErr r)
newtype EMR r a = EM { unEM :: Cont (EMCont r) a }
  deriving...
type EM a = forall r. EMR r a

This almost works. In fact, if we didn't have continuations, it _would_
work. Alas, the need to be able to reify an EM computation and store it
into a Val required either making Val quantify over r (non-universally)
or making Continuation existential. The first doesn't solve the problem,
it just pushes the problem down onto Val. The second doesn't work because
we can't apply an existentially quantified continuation in 'apply', because
the 'r' in the type of 'apply' is universally quantified.

So instead, we force EM actions to produce a Val. This is OK, because we
can use a hack with IORefs to get the actual value we care about instead,
if needed.
-}

{- Note: [EM structure]
EM uses a little trick about continuation monads to embed state and errors,
instead of stacking StateT and ErrorT. The reason for this is that
ConT r (ErrorT e m) a doesn't (and in fact, can't!) provide a MonadError
instance. However, this type can.

Cont r a ~ (a -> r) -> r, so
Cont EMCont a ~ (a -> EvalState -> IO (...)) -> EvalState -> IO (...)
-}
type EMCont = EvalState -> IO (Either LispErr Val, EvalState)
-- | The Evaluation Monad
newtype EM a = EM { unEM :: Cont EMCont a }
  deriving (Functor, Applicative, Monad)

emCont :: ((a -> EMCont) -> EMCont) -> EM a
emCont = EM . cont

emThrow :: LispErr -> EM a
emThrow e = do
  handlersRef <- gets currentHandlers
  handlers    <- liftIO $ readIORef handlersRef
  handler     <- case handlers of
    [] -> error "emThrow: no handlers"
    [handler] -> pure handler -- leave initial handler alone
    (handler:cdrHandlers) ->
      liftIO $ writeIORef handlersRef cdrHandlers >> return handler
  _ <- handler e
  -- If the handler returns, we are to raise an exception with an unspecified
  -- relationship to e. For now, we simply re-raise e itself.
  -- This is moderate future-proofing. If the 'Error' objects ever became
  -- a primitive record type instead of a constructor of 'Val', we'd be in
  -- trouble here.
  emThrow e

-- | State is recovered from the point that 'emCatch' was invoked.
-- This function is for the MonadError EM instance and should not
-- be used in practice, as it doesn't know anything about
-- exception handlers.
emCatch :: EM a -> (LispErr -> EM a) -> EM a
emCatch (EM m) restore = emCont $ \k s -> do
    -- this leaves the catch frame around until the entire continuation
    -- chain, including the continuation of the catch itself, is done.
    -- That seems wrong, so perhaps this should be:
    {- mr <- runEM m (\x s -> pure (Right x, s)) a s
       case mr of
         (Left e, _s0) -> runEM (restore e) k a s
         (Right v, s') -> runEM (return v)  k a s'
    -}
    -- Edit, that doesn't work for type reasons but can work with anIORef.
    -- But why bother? We don't use this function.
    mr <- runCont m k s
    case mr of
        (Left e, _s0)  -> runCont (unEM (restore e)) k s
        (Right _v, _s) -> pure mr

emGet :: EM EvalState
emGet = emCont $ \k s -> k s s

emPut :: EvalState -> EM ()
emPut s = emCont $ \k _s -> k () s

emLiftIO :: IO a -> EM a
emLiftIO io = emCont $ \k s -> io >>= flip k s

-- | Invoking a continuation restores the state to when it was captured.
instance MonadCont EM where
  callCC f = emCont $ \k s ->
    runCont (unEM $ f (\x -> emCont $ \ _ _ -> k x s)) k s
  --{-# INLINE callCC #-}

instance MonadState EvalState EM where
  get = emGet
  --{-# INLINE get #-}
  put = emPut
  --{-# INLINE put #-}

-- | This instance made sense historically, but do the inability of the type
-- of 'catchError' to be instantiated by a function which uses 'Val'-specific
-- exception handlers, it no longer makes sense.
--
-- Consider it deprecated. However, when it is removed, 'EvaluationMonad' will
-- export a function named 'throwError' which behaves as a Haskell-level
-- version of raise.
instance MonadError LispErr EM where
  throwError = emThrow
  catchError = emCatch

instance MonadIO EM where
  liftIO = emLiftIO
  --{-# INLINE liftIO #-}

instance MonadFail EM where
  fail s = throwError . Default $
    "The following error occurred, please report a bug.\n" ++ s
  --{-# INLINE fail #-}

instance HasOpts EM where
  getOpts = gets options
  setOpts opts = modify $ \s -> s { options = opts }

liftIOThrows :: IOThrowsError a -> EM a
liftIOThrows = liftEither <=< liftIO . runExceptT

-- | The current state of evaluation
data EvalState = ES { globalEnv  :: GlobalEnv
                    , localEnv   :: LocalEnv
                    , stack      :: [StackFrame]
                    , dynEnv     :: DynamicEnv
                    , options    :: Opts
                    }

type ExceptionHandler = LispErr -> EM Val

-- | Haskell-level model of the dynamic Scheme environment.
-- Be aware that this is not a dynamic-extent? object
-- ala SRFI-154. It is the single representation of whichever
-- dynamic extent happens to be current at this point in Thcheme's
-- execution. It mutates as Thcheme executes.
data DynamicEnv = DynamicEnv
  { deDynPoint :: Ref DynamicPoint
  , deHandlers :: Ref [ExceptionHandler]
  }

dynPoint :: EvalState -> Ref DynamicPoint
dynPoint = deDynPoint . dynEnv

currentHandlers :: EvalState -> Ref [ExceptionHandler]
currentHandlers = deHandlers . dynEnv

-- | Associate a call in the callTrace with its captured local environment.
data StackFrame = StackFrame Val (Maybe LocalEnv)

-- | Dynamic points; this is the core of the implementation of dynamic-wind.
-- The details of the implementation are mainly sourced from
-- https://www.cs.hmc.edu/~fleck/envision/scheme48/meeting/node7.html
--
-- Each dynamic point stores the "before" and "after" thunks from the
-- dynamic-wind call, as well as the "parent" node, which is either the
-- root, or the dynamic point of the next innermost dynamic-wind call.
-- The root is the Point whose parent is the Sentinel, and its
-- before/after ref contains unspecified values that should not be called.
--
-- The implementation of dynamic-wind spans a couple of modules.
-- Here, continuation objects are defined as holding a DynamicPoint as
-- well as a function; this is the dynamic point of the dynamic extent in
-- which that continuation was captured. When a continuation is captured
-- by callWithCurrentContinuation in Misc.hs, it captures the current value of
-- dereferencing dynPoint as well. When a continuation is applied by
-- 'call' in Evaluation.hs, dynPoint is rerooted to the captured DynamicPoint
-- before the continuation's function itself is called. The implementation of
-- dynamicWind in Misc.hs contains two more rerootDynPoint calls that
-- cause the normal enter-and-exit calls to before and after.
data DynamicPoint = Sentinel | Point (Ref (Val, Val)) (Ref DynamicPoint)
  deriving Eq


{-# LANGUAGE GADTs #-}

--
-- Copyright (c) 2019, ERICSSON AB
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
--     * Redistributions of source code must retain the above copyright notice,
--       this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of the ERICSSON AB nor the names of its contributors
--       may be used to endorse or promote products derived from this software
--       without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--

module Feldspar.Core.Middleend.FromTypeUtil where

import Data.Complex

import Feldspar.Core.Types
import Feldspar.Core.UntypedRepresentation hiding ( Lambda, UntypedFeldF(..)
                                                  , Size, ScalarType(..)
                                                  , Type(..), Signedness
                                                  , Op(..)
                                                  )
import qualified Feldspar.Core.UntypedRepresentation as Ut
import Feldspar.ValueInfo
import Feldspar.Range

untypeType :: TypeRep a -> Size a -> Ut.Type
untypeType UnitType _               = Ut.TupType []
untypeType BoolType _               = 1 Ut.:# Ut.BoolType
untypeType (IntType s n) _          = 1 Ut.:# Ut.IntType (convSign s) (convSize n)
untypeType FloatType _              = 1 Ut.:# Ut.FloatType
untypeType DoubleType _             = 1 Ut.:# Ut.DoubleType
untypeType (ComplexType t) _        = 1 Ut.:# Ut.ComplexType (untypeType t (defaultSize t))
untypeType (Tup2Type a b) (sa,sb)
  = Ut.TupType [untypeType a sa, untypeType b sb]
untypeType (Tup3Type a b c) (sa,sb,sc)
  = Ut.TupType [untypeType a sa, untypeType b sb, untypeType c sc]
untypeType (Tup4Type a b c d) (sa,sb,sc,sd)
  = Ut.TupType [ untypeType a sa, untypeType b sb, untypeType c sc
               , untypeType d sd
               ]
untypeType (Tup5Type a b c d e) (sa,sb,sc,sd,se)
  = Ut.TupType [ untypeType a sa, untypeType b sb, untypeType c sc
               , untypeType d sd, untypeType e se
               ]
untypeType (Tup6Type a b c d e f) (sa,sb,sc,sd,se,sf)
  = Ut.TupType [ untypeType a sa, untypeType b sb, untypeType c sc
               , untypeType d sd, untypeType e se, untypeType f sf
               ]
untypeType (Tup7Type a b c d e f g) (sa,sb,sc,sd,se,sf,sg)
  = Ut.TupType [ untypeType a sa, untypeType b sb, untypeType c sc
               , untypeType d sd, untypeType e se, untypeType f sf
               , untypeType g sg
               ]
untypeType (Tup8Type a b c d e f g h) (sa,sb,sc,sd,se,sf,sg,sh)
  = Ut.TupType [ untypeType a sa, untypeType b sb, untypeType c sc
               , untypeType d sd, untypeType e se, untypeType f sf
               , untypeType g sg, untypeType h sh
               ]
untypeType (Tup9Type a b c d e f g h i) (sa,sb,sc,sd,se,sf,sg,sh,si)
  = Ut.TupType [ untypeType a sa, untypeType b sb, untypeType c sc
               , untypeType d sd, untypeType e se, untypeType f sf
               , untypeType g sg, untypeType h sh, untypeType i si
               ]
untypeType (Tup10Type a b c d e f g h i j) (sa,sb,sc,sd,se,sf,sg,sh,si,sj)
  = Ut.TupType [ untypeType a sa, untypeType b sb, untypeType c sc
               , untypeType d sd, untypeType e se, untypeType f sf
               , untypeType g sg, untypeType h sh, untypeType i si
               , untypeType j sj
               ]
untypeType (Tup11Type a b c d e f g h i j k) (sa,sb,sc,sd,se,sf,sg,sh,si,sj,sk)
  = Ut.TupType [ untypeType a sa, untypeType b sb, untypeType c sc
               , untypeType d sd, untypeType e se, untypeType f sf
               , untypeType g sg, untypeType h sh, untypeType i si
               , untypeType j sj, untypeType k sk
               ]
untypeType (Tup12Type a b c d e f g h i j k l) (sa,sb,sc,sd,se,sf,sg,sh,si,sj,sk,sl)
  = Ut.TupType [ untypeType a sa, untypeType b sb, untypeType c sc
               , untypeType d sd, untypeType e se, untypeType f sf
               , untypeType g sg, untypeType h sh, untypeType i si
               , untypeType j sj, untypeType k sk, untypeType l sl
               ]
untypeType (Tup13Type a b c d e f g h i j k l m) (sa,sb,sc,sd,se,sf,sg,sh,si,sj,sk,sl,sm)
  = Ut.TupType [ untypeType a sa, untypeType b sb, untypeType c sc
               , untypeType d sd, untypeType e se, untypeType f sf
               , untypeType g sg, untypeType h sh, untypeType i si
               , untypeType j sj, untypeType k sk, untypeType l sl
               , untypeType m sm
               ]
untypeType (Tup14Type a b c d e f g h i j k l m n) (sa,sb,sc,sd,se,sf,sg,sh,si,sj,sk,sl,sm,sn)
  = Ut.TupType [ untypeType a sa, untypeType b sb, untypeType c sc
               , untypeType d sd, untypeType e se, untypeType f sf
               , untypeType g sg, untypeType h sh, untypeType i si
               , untypeType j sj, untypeType k sk, untypeType l sl
               , untypeType m sm, untypeType n sn
               ]
untypeType (Tup15Type a b c d e f g h i j k l m n o) (sa,sb,sc,sd,se,sf,sg,sh,si,sj,sk,sl,sm,sn,so)
  = Ut.TupType [ untypeType a sa, untypeType b sb, untypeType c sc
               , untypeType d sd, untypeType e se, untypeType f sf
               , untypeType g sg, untypeType h sh, untypeType i si
               , untypeType j sj, untypeType k sk, untypeType l sl
               , untypeType m sm, untypeType n sn, untypeType o so
               ]
untypeType (MutType a) sz           = Ut.MutType (untypeType a sz)
untypeType (RefType a) sz           = Ut.RefType (untypeType a sz)
untypeType (ArrayType a) (rs :> es) = Ut.ArrayType rs (untypeType a es)
untypeType (MArrType a) (rs :> es)  = Ut.MArrType rs (untypeType a es)
untypeType (ParType a) sz           = Ut.ParType (untypeType a sz)
untypeType (ElementsType a) (rs :> es) = Ut.ElementsType (untypeType a es)
untypeType (ConsType a b) (sa,sb)   = Ut.TupType $ untypeTup (ConsType a b) (sa,sb)
untypeType NilType        _         = Ut.TupType []
untypeType (TupleType t) sz         = untypeType t sz
untypeType (IVarType a) sz          = Ut.IVarType $ untypeType a sz
untypeType (FunType a b) (sa, sz)   = Ut.FunType (untypeType a sa) (untypeType b sz)
untypeType (FValType a) sz          = Ut.FValType (untypeType a sz)
untypeType typ _                    = error "untypeType: missing "

untypeTup :: TypeRep (RTuple a) -> Size (RTuple a) -> [Ut.Type]
untypeTup (ConsType a b) (sa,sb) = untypeType a sa : untypeTup b sb
untypeTup NilType        _       = []

convSign :: Signedness a -> Ut.Signedness
convSign U       = Unsigned
convSign S       = Signed

convSize :: BitWidth a -> Ut.Size
convSize N8      = S8
convSize N16     = S16
convSize N32     = S32
convSize N64     = S64
convSize NNative = S32

literal :: TypeRep a -> Size a -> a -> Lit
literal t@UnitType        sz a = literalConst t sz a
literal t@BoolType        sz a = literalConst t sz a
literal t@IntType{}       sz a = literalConst t sz a
literal t@FloatType       sz a = literalConst t sz a
literal t@DoubleType      sz a = literalConst t sz a
literal t@ComplexType{}   sz a = literalConst t sz a
literal t@ArrayType{}     sz a = literalConst t sz a
literal (Tup2Type ta tb) (sa,sb) (a,b)
    = LTup [literal ta sa a, literal tb sb b]

literal (Tup3Type ta tb tc) (sa,sb,sc) (a,b,c)
    = LTup [literal ta sa a, literal tb sb b, literal tc sc c]

literal (Tup4Type ta tb tc td) (sa,sb,sc,sd) (a,b,c,d)
    = LTup [ literal ta sa a, literal tb sb b, literal tc sc c
           , literal td sd d
           ]

literal (Tup5Type ta tb tc td te) (sa,sb,sc,sd,se) (a,b,c,d,e)
    = LTup [ literal ta sa a, literal tb sb b, literal tc sc c
           , literal td sd d, literal te se e
           ]

literal (Tup6Type ta tb tc td te tf) (sa,sb,sc,sd,se,sf) (a,b,c,d,e,f)
    = LTup [ literal ta sa a, literal tb sb b, literal tc sc c
           , literal td sd d, literal te se e, literal tf sf f
           ]

literal (Tup7Type ta tb tc td te tf tg) (sa,sb,sc,sd,se,sf,sg) (a,b,c,d,e,f,g)
    = LTup [ literal ta sa a, literal tb sb b, literal tc sc c
           , literal td sd d, literal te se e, literal tf sf f
           , literal tg sg g
           ]
literal t s a = error "Missing pattern: FromTyped.hs: literal"

literalConst :: TypeRep a -> Size a -> a -> Lit
literalConst UnitType        _  ()     = LTup []
literalConst BoolType        _  a      = LBool a
literalConst (IntType s n)   sz a      = LInt (convSign s) (convSize n) (toInteger a)
literalConst FloatType       _  a      = LFloat a
literalConst DoubleType      _  a      = LDouble a
literalConst (ArrayType t)   _  a      = LArray t' $ map (literalConst t (defaultSize t)) a
  where t' = untypeType t (defaultSize t)
literalConst (ComplexType t) _  (r:+i) = LComplex re ie
  where re = literalConst t (defaultSize t) r
        ie = literalConst t (defaultSize t) i

-- | Construct a ValueInfo from a TypeRep and a Size
toValueInfo :: TypeRep a -> Size a -> ValueInfo
toValueInfo UnitType          _             = VIProd []
-- FIXME: No range for boolean types yet.
toValueInfo BoolType          _             = VIBool    (Range 0 1)
toValueInfo (IntType U N8)    r             = VIWord8   r
toValueInfo (IntType S N8)    r             = VIInt8    r
toValueInfo (IntType U N16)   r             = VIWord16  r
toValueInfo (IntType S N16)   r             = VIInt16   r
toValueInfo (IntType U N32)   r             = VIWord32  r
toValueInfo (IntType S N32)   r             = VIInt32   r
toValueInfo (IntType U N64)   r             = VIWord64  r
toValueInfo (IntType S N64)   r             = VIInt64   r
toValueInfo (IntType U NNative) r           = VIWordN   r
toValueInfo (IntType S NNative) r           = VIIntN    r
-- FIXME: No range for FP types and ComplexType yet.
toValueInfo FloatType         _             = VIFloat
toValueInfo DoubleType        _             = VIDouble
toValueInfo (ComplexType _)   _             = VIProd []
toValueInfo (Tup2Type a b) (sa,sb)
  = VIProd [toValueInfo a sa, toValueInfo b sb]
toValueInfo (Tup3Type a b c) (sa,sb,sc)
  = VIProd [toValueInfo a sa, toValueInfo b sb, toValueInfo c sc]
toValueInfo (Tup4Type a b c d) (sa,sb,sc,sd)
  = VIProd [ toValueInfo a sa, toValueInfo b sb, toValueInfo c sc
           , toValueInfo d sd
           ]
toValueInfo (Tup5Type a b c d e) (sa,sb,sc,sd,se)
  = VIProd [ toValueInfo a sa, toValueInfo b sb, toValueInfo c sc
           , toValueInfo d sd, toValueInfo e se
           ]
toValueInfo (Tup6Type a b c d e f) (sa,sb,sc,sd,se,sf)
  = VIProd [ toValueInfo a sa, toValueInfo b sb, toValueInfo c sc
           , toValueInfo d sd, toValueInfo e se, toValueInfo f sf
           ]
toValueInfo (Tup7Type a b c d e f g) (sa,sb,sc,sd,se,sf,sg)
  = VIProd [ toValueInfo a sa, toValueInfo b sb, toValueInfo c sc
           , toValueInfo d sd, toValueInfo e se, toValueInfo f sf
           , toValueInfo g sg
           ]
toValueInfo (Tup8Type a b c d e f g h) (sa,sb,sc,sd,se,sf,sg,sh)
  = VIProd [ toValueInfo a sa, toValueInfo b sb, toValueInfo c sc
           , toValueInfo d sd, toValueInfo e se, toValueInfo f sf
           , toValueInfo g sg, toValueInfo h sh
           ]
toValueInfo (Tup9Type a b c d e f g h i) (sa,sb,sc,sd,se,sf,sg,sh,si)
  = VIProd [ toValueInfo a sa, toValueInfo b sb, toValueInfo c sc
           , toValueInfo d sd, toValueInfo e se, toValueInfo f sf
           , toValueInfo g sg, toValueInfo h sh, toValueInfo i si
            ]
toValueInfo (Tup10Type a b c d e f g h i j) (sa,sb,sc,sd,se,sf,sg,sh,si,sj)
  = VIProd [ toValueInfo a sa, toValueInfo b sb, toValueInfo c sc
           , toValueInfo d sd, toValueInfo e se, toValueInfo f sf
           , toValueInfo g sg, toValueInfo h sh, toValueInfo i si
           , toValueInfo j sj
           ]
toValueInfo (Tup11Type a b c d e f g h i j k) (sa,sb,sc,sd,se,sf,sg,sh,si,sj,sk)
  = VIProd [ toValueInfo a sa, toValueInfo b sb, toValueInfo c sc
           , toValueInfo d sd, toValueInfo e se, toValueInfo f sf
           , toValueInfo g sg, toValueInfo h sh, toValueInfo i si
           , toValueInfo j sj, toValueInfo k sk
           ]
toValueInfo (Tup12Type a b c d e f g h i j k l) (sa,sb,sc,sd,se,sf,sg,sh,si,sj,sk,sl)
  = VIProd [ toValueInfo a sa, toValueInfo b sb, toValueInfo c sc
           , toValueInfo d sd, toValueInfo e se, toValueInfo f sf
           , toValueInfo g sg, toValueInfo h sh, toValueInfo i si
           , toValueInfo j sj, toValueInfo k sk, toValueInfo l sl
           ]
toValueInfo (Tup13Type a b c d e f g h i j k l m) (sa,sb,sc,sd,se,sf,sg,sh,si,sj,sk,sl,sm)
  = VIProd [ toValueInfo a sa, toValueInfo b sb, toValueInfo c sc
           , toValueInfo d sd, toValueInfo e se, toValueInfo f sf
           , toValueInfo g sg, toValueInfo h sh, toValueInfo i si
           , toValueInfo j sj, toValueInfo k sk, toValueInfo l sl
           , toValueInfo m sm
           ]
toValueInfo (Tup14Type a b c d e f g h i j k l m n) (sa,sb,sc,sd,se,sf,sg,sh,si,sj,sk,sl,sm,sn)
  = VIProd [ toValueInfo a sa, toValueInfo b sb, toValueInfo c sc
           , toValueInfo d sd, toValueInfo e se, toValueInfo f sf
           , toValueInfo g sg, toValueInfo h sh, toValueInfo i si
           , toValueInfo j sj, toValueInfo k sk, toValueInfo l sl
           , toValueInfo m sm, toValueInfo n sn
           ]
toValueInfo (Tup15Type a b c d e f g h i j k l m n o) (sa,sb,sc,sd,se,sf,sg,sh,si,sj,sk,sl,sm,sn,so)
  = VIProd [ toValueInfo a sa, toValueInfo b sb, toValueInfo c sc
           , toValueInfo d sd, toValueInfo e se, toValueInfo f sf
           , toValueInfo g sg, toValueInfo h sh, toValueInfo i si
           , toValueInfo j sj, toValueInfo k sk, toValueInfo l sl
           , toValueInfo m sm, toValueInfo n sn, toValueInfo o so
           ]
toValueInfo (MutType a) sz                  = toValueInfo a sz
toValueInfo (RefType a) sz                  = toValueInfo a sz
toValueInfo (ArrayType a) (Range (WordN l) (WordN r) :> es)
  = VIProd [VIWord32 (Range l r), toValueInfo a es]
toValueInfo (MArrType a) (Range (WordN l) (WordN r) :> es)
  = VIProd [VIWord32 (Range l r), toValueInfo a es]
toValueInfo (ParType a) sz                  = toValueInfo a sz
toValueInfo (ElementsType a) (Range (WordN l) (WordN r) :> es)
  = VIProd [VIWord32 (Range l r), toValueInfo a es]
toValueInfo (ConsType a b) (sa,sb) = VIProd $ toValueInfo a sa : ss
  where VIProd ss = toValueInfo b sb
toValueInfo NilType _ = VIProd []
toValueInfo (TupleType t) sz = toValueInfo t sz
toValueInfo (IVarType a) sz                 = toValueInfo a sz
-- TODO: Maybe keep argument information for FunType.
toValueInfo (FunType a b) (sa, _)           = toValueInfo a sa
toValueInfo (FValType a) sz                 = toValueInfo a sz
toValueInfo typ _
  = error $ "toValueInfo: missing case for " ++ show typ


-- |
-- Copyright: (C) 2013 Amgen, Inc.
--
-- Low-level bindings to core R datatypes and functions. Nearly all structures
-- allocated internally in R are instances of a 'SEXPREC'. A pointer to
-- a 'SEXPREC' is called a 'SEXP'.
--
-- To allow for precise typing of bindings to primitive R functions, we index
-- 'SEXP's by 'SEXPTYPE', which classifies the /form/ of a 'SEXP' (see
-- "Foreign.R.Type"). A function accepting 'SEXP' arguments of any type should
-- leave the type index uninstantiated. A function returning a 'SEXP' result of
-- unknown type should use 'SomeSEXP'. (More precisely, unknown types in
-- /negative/ position should be /universally/ quantified and unknown types in
-- /positive/ position should be /existentially/ quantified).
--
-- This module is intended to be imported qualified.

{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE DeriveDataTypeable #-}
#endif
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

-- Warns about some sanity checks like IsVector, that has no methods and are
-- not used.
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module Foreign.R
  ( module Foreign.R.Type
    -- * Internal R structures
  , SEXP(..)
  , SomeSEXP(..)
  , unSomeSEXP
    -- * Casts and coercions
    -- $cast-coerce
  , cast
  , asTypeOf
  , unsafeCoerce
    -- * Node creation
  , allocSEXP
  , allocList
  , allocVector
  , allocVectorProtected
  , install
  , mkString
  , mkChar
  , CEType(..)
  , mkCharCE
  , mkCharLenCE
  , mkWeakRef
    -- * Node attributes
  , typeOf
  , isS4
  , setAttributes
  , getAttribute
  , getAttributes
    -- * Node accessor functions
    -- ** Lists
  , cons
  , lcons
  , car
  , cdr
  , tag
  , setCar
  , setCdr
  , setTag
    -- ** Environments
  , envFrame
  , envEnclosing
  , envHashtab
    -- ** Closures
  , closureFormals
  , closureBody
  , closureEnv
    -- ** Promises
  , promiseCode
  , promiseEnv
  , promiseValue
    -- ** Symbols
  , symbolPrintName
  , symbolValue
  , symbolInternal
    -- ** Vectors
  , length
  , trueLength
  , char
  , real
  , integer
  , logical
  , complex
  , raw
  , string
  , unsafeSEXPToVectorPtr
  , unsafeVectorPtrToSEXP
  , readVector
  , writeVector
    -- * Evaluation
  , eval
  , tryEval
  , tryEvalSilent
  , lang1
  , lang2
  , lang3
  , findFun
  , findVar
    -- * GC functions
  , protect
  , unprotect
  , unprotectPtr
  , preserveObject
  , releaseObject
  , gc
    -- * Globals
  , isRInteractive
  , nilValue
  , unboundValue
  , missingArg
  , baseEnv
  , emptyEnv
  , globalEnv
  , signalHandlers
  , interruptsPending
    -- * Communication with runtime
  , printValue
    -- * Low level info header access
  , SEXPInfo(..)
  , peekInfo
  , pokeInfo
  , mark
  , named
  -- * Internal types and functions
  --
  -- | Should not be used in user code. These exports are only needed for
  -- binding generation tools.
  , SEXPREC
  , SEXP0
  , sexp
  , unsexp
  , release
  , unsafeRelease
  , unsafeReleaseSome
  , withProtected
  -- * Deprecated
  , indexVector
  ) where

import Control.Memory.Region
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid ((<>))
#endif
import Foreign.R.Internal
import Foreign.R.Type
import Foreign.R.Type as R

import Control.Applicative
import Control.Exception (bracket)
import Data.Complex
import Data.Int (Int32)
#if __GLASGOW_HASKELL__ < 710
import Data.Typeable (Typeable)
#endif
import Foreign (Ptr, castPtr)
import Foreign.C
import Foreign.R.Context (rCtx, SEXP0, SEXPREC)
import qualified Language.C.Inline as C
import Prelude hiding (asTypeOf, length)

#define USE_RINTERNALS
#include <Rinternals.h>

C.context (C.baseCtx <> rCtx)
C.include "<Rinternals.h>"
C.include "<stdlib.h>"
C.include "<stdint.h>"

--------------------------------------------------------------------------------
-- Generic accessor functions                                                 --
--------------------------------------------------------------------------------

-- | read CAR object value
car :: SEXP s a -> IO (SomeSEXP s)
car (unsexp -> s) = somesexp <$> [C.exp| SEXP { CAR( $(SEXP s) ) } |]

-- | read CDR object
cdr :: SEXP s a -> IO (SomeSEXP s)
cdr (unsexp -> s) = somesexp <$> [C.exp| SEXP { CAR( $(SEXP s) ) } |]

-- | read object`s Tag
tag :: SEXP s a -> IO (SomeSEXP s)
tag (unsexp -> s) = somesexp <$> [C.exp| SEXP { TAG( $(SEXP s) ) } |]

--------------------------------------------------------------------------------
-- Environment functions                                                      --
--------------------------------------------------------------------------------

envFrame :: (SEXP s 'R.Env) -> IO (SEXP s R.PairList)
envFrame (unsexp -> s) = sexp <$> [C.exp| SEXP { FRAME( $(SEXP s) ) } |]

-- | Enclosing environment.
envEnclosing :: SEXP s 'R.Env -> IO (SEXP s 'R.Env)
envEnclosing (unsexp -> s) = sexp <$> [C.exp| SEXP { ENCLOS( $(SEXP s) ) } |]

-- | Hash table associated with the environment, used for faster name lookups.
envHashtab :: SEXP s 'R.Env -> IO (SEXP s 'R.Vector)
envHashtab (unsexp -> s) = sexp <$> [C.exp| SEXP { HASHTAB( $(SEXP s) ) } |]

--------------------------------------------------------------------------------
-- Closure functions                                                          --
--------------------------------------------------------------------------------

-- | Closure formals (aka the actual arguments).
closureFormals :: SEXP s 'R.Closure -> IO (SEXP s R.PairList)
closureFormals (unsexp -> s) = sexp <$> [C.exp| SEXP { FORMALS( $(SEXP s) ) }|]

-- | The code of the closure.
closureBody :: SEXP s 'R.Closure -> IO (SomeSEXP s)
closureBody (unsexp -> s) = somesexp <$> [C.exp| SEXP { BODY( $(SEXP s) ) } |]

-- | The environment of the closure.
closureEnv :: SEXP s 'R.Closure -> IO (SEXP s 'R.Env)
closureEnv (unsexp -> s) = sexp <$> [C.exp| SEXP { CLOENV( $(SEXP s) ) }|]

--------------------------------------------------------------------------------
-- Promise functions                                                          --
--------------------------------------------------------------------------------

-- | The code of a promise.
promiseCode :: SEXP s 'R.Promise -> IO (SomeSEXP s)
promiseCode (unsexp -> s) = somesexp <$> [C.exp| SEXP { PRCODE( $(SEXP s) )}|]

-- | The environment in which to evaluate the promise.
promiseEnv :: SEXP s 'R.Promise -> IO (SomeSEXP s)
promiseEnv (unsexp -> s) = somesexp <$> [C.exp| SEXP { PRENV( $(SEXP s) )}|]

-- | The value of the promise, if it has already been forced.
promiseValue :: SEXP s 'R.Promise -> IO (SomeSEXP s)
promiseValue (unsexp -> s) = somesexp <$> [C.exp| SEXP { PRVALUE( $(SEXP s) )}|]

--------------------------------------------------------------------------------
-- Vector accessor functions                                                  --
--------------------------------------------------------------------------------

-- | Read True Length vector field.
trueLength :: R.IsVector a => SEXP s a -> IO CInt
trueLength (unsexp -> s) = [C.exp| int { TRUELENGTH( $(SEXP s) ) }|]

-- | Read character vector data
char :: SEXP s 'R.Char -> IO CString
char (unsexp -> s) = castPtr <$> [C.exp| const char* { CHAR($(SEXP s))}|]
-- XXX: check if we really need Word8 here, maybe some better handling of
-- encoding

-- | Read real vector data.
real :: SEXP s 'R.Real -> IO (Ptr Double)
real (unsexp -> s) = castPtr <$> [C.exp| double* { REAL( $(SEXP s)) }|]

-- | Read integer vector data.
integer :: SEXP s 'R.Int -> IO (Ptr Int32)
integer (unsexp -> s) = [C.exp| int32_t* { INTEGER( $(SEXP s) )}|]

-- | Read raw data.
raw :: SEXP s 'R.Raw -> IO (Ptr CChar)
raw (unsexp -> s) = [C.exp| char* { RAW($(SEXP s)) } |]

-- | Read logical vector data.
logical :: SEXP s 'R.Logical -> IO (Ptr R.Logical)
logical (unsexp -> s) = castPtr <$>
  [C.exp| int* { LOGICAL($(SEXP s)) } |]

-- | Read complex vector data.
complex :: SEXP s 'R.Complex -> IO (Ptr (Complex Double))
complex (unsexp -> s) = [C.exp| Rcomplex* { COMPLEX($(SEXP s)) }|]

-- | Read string vector data.
string :: SEXP s 'R.String -> IO (Ptr (SEXP s 'R.Char))
string (unsexp -> s) = castPtr <$>
  [C.exp| SEXP* { STRING_PTR($(SEXP s)) }|]

readVector :: R.IsGenericVector a => SEXP s a -> Int -> IO (SomeSEXP s)
readVector (unsexp -> s) (fromIntegral -> n) = somesexp <$>
  [C.exp| SEXP { VECTOR_ELT( $(SEXP s), $(int n) ) } |]

indexVector :: IsGenericVector a => SEXP s a -> Int -> IO (SomeSEXP s)
{-# DEPRECATED indexVector "Use readVector instead." #-}
indexVector = readVector

writeVector :: R.IsGenericVector a => SEXP s a -> Int -> SEXP s b -> IO (SEXP s a)
writeVector (unsexp -> a) (fromIntegral -> n) (unsexp -> b) = sexp <$>
  [C.exp| SEXP { SET_VECTOR_ELT($(SEXP a),$(int n), $(SEXP b)) } |]

--------------------------------------------------------------------------------
-- Symbol accessor functions                                                  --
--------------------------------------------------------------------------------

-- | Read a name from symbol.
symbolPrintName :: SEXP s 'R.Symbol -> IO (SEXP s a)
symbolPrintName (unsexp -> s) = sexp <$> [C.exp| SEXP { PRINTNAME( $(SEXP s)) } |]

-- | Read value from symbol.
symbolValue :: SEXP s 'R.Symbol -> IO (SEXP s a)
symbolValue (unsexp -> s) = sexp <$> [C.exp| SEXP { SYMVALUE( $(SEXP s)) } |]

-- | Read internal value from symbol.
symbolInternal :: SEXP s 'R.Symbol -> IO (SEXP s a)
symbolInternal (unsexp -> s) = sexp <$> [C.exp| SEXP { INTERNAL( $(SEXP s)) }|]

--------------------------------------------------------------------------------
-- Value contruction                                                          --
--------------------------------------------------------------------------------

-- | Initialize a new string vector.
mkString :: CString -> IO (SEXP V 'R.String)
mkString value = sexp <$>  [C.exp| SEXP { Rf_mkString($(char * value)) } |]

-- | Initialize a new character vector (aka a string).
mkChar :: CString -> IO (SEXP V 'R.Char)
mkChar value = sexp <$> [C.exp| SEXP { Rf_mkChar($(char * value)) } |]

-- | Create Character value with specified encoding
mkCharCE :: CEType -> CString -> IO (SEXP V 'R.Char)
mkCharCE (cIntFromEnum -> ce) value = sexp <$>
  [C.exp| SEXP  { Rf_mkCharCE($(char * value), $(int ce)) } |]

mkCharLenCE :: CEType -> CString -> Int -> IO (SEXP V 'R.Char)
mkCharLenCE (cIntFromEnum -> ce) value (fromIntegral -> len) = sexp <$>
  [C.exp| SEXP { Rf_mkCharLenCE($(char * value), $(int len), $(int ce)) } |]

-- | Intern a string @name@ into the symbol table.
--
-- If @name@ is not found, it is added to the symbol table. The symbol
-- corresponding to the string @name@ is returned.
install :: CString -> IO (SEXP V 'R.Symbol)
install name = sexp <$>
  [C.exp| SEXP { Rf_install($(char * name)) }|]

-- | Allocate a 'SEXP'.
allocSEXP :: SSEXPTYPE a -> IO (SEXP V a)
allocSEXP (cUIntFromSingEnum -> s) = sexp <$>
  [C.exp| SEXP { Rf_allocSExp( $(unsigned int s) ) }|]

-- | Allocate a pairlist of 'SEXP's, chained together.
allocList :: Int -> IO (SEXP V 'R.List)
allocList (fromIntegral -> n) = sexp <$> [C.exp| SEXP {Rf_allocList($(int n))} |]

-- | Allocate Vector.
allocVector :: R.IsVector a => SSEXPTYPE a -> Int -> IO (SEXP V a)
allocVector (cUIntFromSingEnum -> p) (fromIntegral -> n) = sexp <$>
  [C.exp| SEXP {Rf_allocVector( $(unsigned int p), $(int n)) } |]

allocVectorProtected :: (R.IsVector a) => SSEXPTYPE a -> Int -> IO (SEXP s a)
allocVectorProtected ty n = fmap release (protect =<< allocVector ty n)

-- | Allocate a so-called cons cell, in essence a pair of 'SEXP' pointers.
cons :: SEXP s a -> SEXP s b -> IO (SEXP V 'R.List)
cons (unsexp -> a) (unsexp -> b) = sexp <$>
  [C.exp| SEXP { Rf_cons($(SEXP a), $(SEXP b)) }|]

-- | Allocate a so-called cons cell of language objects, in essence a pair of
-- 'SEXP' pointers.
lcons :: SEXP s a -> SEXP s b -> IO (SEXP V 'R.Lang)
lcons (unsexp -> a) (unsexp -> b) = sexp <$>
  [C.exp| SEXP { Rf_lcons($(SEXP a), $(SEXP b)) } |]

printValue :: SEXP s a -> IO ()
printValue (unsexp -> s) =
  [C.exp| void { Rf_PrintValue($(SEXP s)) }|]

--------------------------------------------------------------------------------
-- Garbage collection                                                         --
--------------------------------------------------------------------------------

-- | Protect a 'SEXP' from being garbage collected by R. It is in particular
-- necessary to do so for objects that are not yet pointed by any other object,
-- e.g. when constructing a tree bottom-up rather than top-down.
--
-- To avoid unbalancing calls to 'protect' and 'unprotect', do not use these
-- functions directly but use 'Language.R.withProtected' instead.
protect :: SEXP s a -> IO (SEXP G a)
protect (unsexp -> s) = sexp <$>
  [C.exp| SEXP { Rf_protect($(SEXP s)) }|]

-- | @unprotect n@ unprotects the last @n@ objects that were protected.
unprotect :: Int -> IO ()
unprotect (fromIntegral -> i) =
  [C.exp| void { Rf_unprotect($(int i)) } |]

-- | Unprotect a specific object, referred to by pointer.
unprotectPtr :: SEXP G a -> IO ()
unprotectPtr (unsexp -> s) =
  [C.exp| void { Rf_unprotect_ptr($(SEXP s)) }|]

-- | Invoke an R garbage collector sweep.
gc :: IO ()
gc = [C.exp| void { R_gc() }|]

-- | Preserve an object accross GCs.
preserveObject :: SEXP s a -> IO ()
preserveObject (unsexp -> s) =
  [C.exp| void { R_PreserveObject( $(SEXP s) )} |]

-- | Allow GC to remove an preserved object.
releaseObject :: SEXP s a -> IO ()
releaseObject (unsexp -> s) =
  [C.exp| void { R_ReleaseObject( $(SEXP s) )} |]

--------------------------------------------------------------------------------
-- Evaluation                                                                 --
--------------------------------------------------------------------------------

-- | Evaluate any 'SEXP' to its value.
eval :: SEXP s a -> SEXP s 'R.Env -> IO (SomeSEXP V)
eval (unsexp -> expr) (unsexp -> env) = somesexp <$>
  [C.exp| SEXP { Rf_eval($(SEXP expr), $(SEXP env)) }|]

-- | Try to evaluate expression.
tryEval :: SEXP s a -> SEXP s 'R.Env -> Ptr CInt -> IO (SomeSEXP V)
tryEval (unsexp -> expr) (unsexp -> env) retCode = somesexp <$>
  [C.exp| SEXP { R_tryEval($(SEXP expr), $(SEXP env), $(int* retCode)) }|]

-- | Try to evaluate without printing error/warning messages to stdout.
tryEvalSilent :: SEXP  s a -> SEXP s 'R.Env -> Ptr CInt -> IO (SomeSEXP V)
tryEvalSilent (unsexp -> expr) (unsexp -> env) retCode = somesexp <$>
  [C.exp| SEXP { R_tryEvalSilent($(SEXP expr), $(SEXP env), $(int* retCode)) }|]

-- | Construct a nullary function call.
lang1 :: SEXP s a -> IO (SEXP V 'R.Lang)
lang1 (unsexp -> s) = sexp <$>
  [C.exp| SEXP {Rf_lang1($(SEXP s)) }|]

-- | Construct unary function call.
lang2 :: SEXP s a -> SEXP s b ->  IO (SEXP V 'R.Lang)
lang2 (unsexp -> f) (unsexp -> x) = sexp <$>
  [C.exp| SEXP {Rf_lang2($(SEXP f), $(SEXP x)) }|]

-- | Construct a binary function call.
lang3 :: SEXP s a -> SEXP s b ->  SEXP s c -> IO (SEXP V 'R.Lang)
lang3 (unsexp -> f) (unsexp -> x) (unsexp -> y) = sexp <$>
  [C.exp| SEXP {Rf_lang3($(SEXP f), $(SEXP x), $(SEXP y)) }|]

-- | Find a function by name.
findFun :: SEXP s a -> SEXP s 'R.Env -> IO (SomeSEXP s)
findFun (unsexp -> a) (unsexp -> env) = somesexp <$>
  [C.exp| SEXP { Rf_findFun($(SEXP a), $(SEXP env)) }|]

-- | Find a variable by name.
findVar :: SEXP s a -> SEXP s 'R.Env -> IO (SEXP s 'R.Symbol)
findVar (unsexp -> a) (unsexp -> env) = sexp <$>
  [C.exp| SEXP {Rf_findVar($(SEXP a), $(SEXP env))}|]

mkWeakRef :: SEXP s a -> SEXP s b -> SEXP s c -> Bool -> IO (SEXP V 'R.WeakRef)
mkWeakRef (unsexp -> a) (unsexp -> b) (unsexp -> c) (cIntFromEnum -> t) = sexp <$>
  [C.exp| SEXP {R_MakeWeakRef($(SEXP a), $(SEXP b), $(SEXP c), $(int t))}|]

-------------------------------------------------------------------------------
-- Encoding                                                                  --
-------------------------------------------------------------------------------

-- | Content encoding.
data CEType
  = CE_Native
  | CE_UTF8
  | CE_Latin1
  | CE_Bytes
  | CE_Symbol
  | CE_Any
  deriving (Eq, Show)

instance Enum CEType where
  fromEnum CE_Native = #const CE_NATIVE
  fromEnum CE_UTF8   = #const CE_UTF8
  fromEnum CE_Latin1 = #const CE_LATIN1
  fromEnum CE_Bytes  = #const CE_BYTES
  fromEnum CE_Symbol = #const CE_SYMBOL
  fromEnum CE_Any    = #const CE_ANY
  toEnum i = case i of
    (#const CE_NATIVE) -> CE_Native
    (#const CE_UTF8)   -> CE_UTF8
    (#const CE_LATIN1) -> CE_Latin1
    (#const CE_BYTES)  -> CE_Bytes
    (#const CE_SYMBOL) -> CE_Symbol
    (#const CE_ANY)    -> CE_Any
    _ -> error "CEType.fromEnum: unknown tag"

-- | Perform an action with resource while protecting it from the garbage
-- collection. This function is a safer alternative to 'R.protect' and
-- 'R.unprotect', guaranteeing that a protected resource gets unprotected
-- irrespective of the control flow, much like 'Control.Exception.bracket_'.
withProtected :: IO (SEXP V a)      -- Action to acquire resource
              -> (SEXP s a -> IO b) -- Action
              -> IO b
withProtected create f =
    bracket
      (do { x <- create; _ <- protect x; return x })
      (const $ unprotect 1)
      (f . unsafeRelease)


{-# language TemplateHaskellQuotes #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language ScopedTypeVariables #-}
{-# language DataKinds #-}
{-# language TypeOperators #-}
{-# language EmptyCase #-}
{-# language DefaultSignatures #-}
{-# language BangPatterns #-}

module Language.Haskell.TH.TraverseCode
  ( TraverseCode (..)
  , sequenceCode
  , genericTraverseCode
  , genericSequenceCode
  ) where
import Generics.Linear
import Language.Haskell.TH.Syntax (Code, Lift (..), Exp (..), Quote, Name)
import qualified Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH.Lib (conE)

-- for instances
import qualified Data.Functor.Product as FProd
import qualified Data.Functor.Sum as FSum
import Data.Functor.Identity
import qualified Data.Sequence.Internal as Seq
import Data.Coerce
import Control.Applicative
import qualified Data.Semigroup as S
import qualified Data.Monoid as M
import qualified Data.Complex as Complex
import qualified Data.Ord as Ord
import qualified Data.Functor.Compose as Compose
import qualified Data.Tree as Tree
import qualified Data.List.NonEmpty as NonEmpty
import GHC.Tuple (Solo)
import Data.Proxy (Proxy)
import qualified GHC.Generics as GHCGenerics
import qualified Data.Array as Ar
import qualified Data.Primitive.Array as PAr
import qualified Data.Primitive.SmallArray as PSmAr
import Data.Foldable (toList)

-- | Containers supporting \"traversal\" in 'Code'.
class TraverseCode t where
  -- | Given a container and a function to fill it with splices,
  -- produce a splice that will generate a container of their results.
  traverseCode :: Quote m => (a -> Code m b) -> t a -> Code m (t b)

  default traverseCode :: (Quote m, GTraverseCode (Rep1 t), Generic1 t) => (a -> Code m b) -> t a -> Code m (t b)
  traverseCode = genericTraverseCode

-- | Given a container of splices, produce a splice that will generate a
-- container of their results.
sequenceCode :: (TraverseCode t, Quote m) => t (Code m a) -> Code m (t a)
sequenceCode = traverseCode id

-- | Like 'sequenceCode', but using the @"Generics.Linear".'Generic1'@ instance.
genericSequenceCode :: (Quote m, GTraverseCode (Rep1 t), Generic1 t) => t (Code m a) -> Code m (t a)
genericSequenceCode = TH.unsafeCodeCoerce . gtraverseCode id . from1

-- | Like 'traverseCode', but using the @"Generics.Linear".'Generic1'@ instance.
genericTraverseCode :: (Quote m, GTraverseCode (Rep1 t), Generic1 t) => (a -> Code m b) -> t a -> Code m (t b)
genericTraverseCode f = TH.unsafeCodeCoerce . gtraverseCode f . from1

class GTraverseCode f where
  gtraverseCode :: Quote m => (a -> Code m b) -> f a -> m Exp

instance (Datatype c, GTraverseCodeCon f) => GTraverseCode (D1 c f) where
  gtraverseCode f m@(M1 x) = gtraverseCodeCon pkg modl f x
    where
      pkg = packageName m
      modl = moduleName m

class GTraverseCodeCon f where
  gtraverseCodeCon :: Quote m => String -> String -> (a -> Code m b) -> f a -> m Exp

-- This instance seems totally useless, but it's obviously valid.
instance GTraverseCodeCon V1 where
  gtraverseCodeCon _pkg _modl _f x = case x of

instance (GTraverseCodeCon f, GTraverseCodeCon g) => GTraverseCodeCon (f :+: g) where
  gtraverseCodeCon pkg modl f (L1 x) = gtraverseCodeCon pkg modl f x
  gtraverseCodeCon pkg modl f (R1 y) = gtraverseCodeCon pkg modl f y

instance (Constructor c, GTraverseCodeFields f) => GTraverseCodeCon (C1 c f) where
  gtraverseCodeCon pkg modl f m@(M1 x) = gtraverseCodeFields (conE conN) f x
    where
      conBase = conName m
      conN :: Name
      conN = TH.mkNameG_d pkg modl conBase

class GTraverseCodeFields f where
  gtraverseCodeFields :: Quote m => m Exp -> (a -> Code m b) -> f a -> m Exp

instance GTraverseCodeFields f => GTraverseCodeFields (S1 c f) where
  gtraverseCodeFields c f (M1 x) = gtraverseCodeFields c f x

instance (GTraverseCodeFields f, GTraverseCodeFields g) => GTraverseCodeFields (f :*: g) where
  gtraverseCodeFields c f (x :*: y) =
    gtraverseCodeFields (gtraverseCodeFields c f x) f y

instance Lift p => GTraverseCodeFields (K1 i p) where
  gtraverseCodeFields c _f (K1 x) = [| $c x |]

instance GTraverseCodeFields Par1 where
  gtraverseCodeFields cc f (Par1 ca) = [| $cc $(TH.unTypeCode (f ca)) |]

instance GTraverseCodeFields U1 where
  gtraverseCodeFields cc _f U1 = cc

instance (GTraverseCodeFields f, TraverseCode g) => GTraverseCodeFields (f :.: g) where
  gtraverseCodeFields cc f (Comp1 x) =
    gtraverseCodeFields cc (traverseCode f) x

instance GTraverseCodeFields (URec Char) where
  gtraverseCodeFields c _f (UChar ch) = [| $c (UChar ch) |]

instance GTraverseCodeFields (URec Float) where
  gtraverseCodeFields c _f (UFloat ch) = [| $c (UFloat ch) |]

instance GTraverseCodeFields (URec Double) where
  gtraverseCodeFields c _f (UDouble ch) = [| $c (UDouble ch) |]

instance GTraverseCodeFields (URec Int) where
  gtraverseCodeFields c _f (UInt ch) = [| $c (UInt ch) |]

instance GTraverseCodeFields (URec Word) where
  gtraverseCodeFields c _f (UWord ch) = [| $c (UWord ch) |]

instance GTraverseCodeFields f => GTraverseCodeFields (MP1 m f) where
  gtraverseCodeFields c f (MP1 x) = gtraverseCodeFields c f x

-- Would an instance for URec (Ptr ()) make any sense?

-- TraverseCode instances

instance TraverseCode Maybe
instance TraverseCode Identity
instance TraverseCode []
instance TH.Lift a => TraverseCode (Either a)

instance TH.Lift a => TraverseCode ((,) a)
instance (TH.Lift a, TH.Lift b) => TraverseCode ((,,) a b)
instance (TH.Lift a, TH.Lift b, TH.Lift c) => TraverseCode ((,,,) a b c)
instance (TH.Lift a, TH.Lift b, TH.Lift c, TH.Lift d) => TraverseCode ((,,,,) a b c d)
instance (TH.Lift a, TH.Lift b, TH.Lift c, TH.Lift d, TH.Lift e) => TraverseCode ((,,,,,) a b c d e)

instance (TraverseCode f, TraverseCode g) => TraverseCode (FProd.Product f g)
instance (TraverseCode f, TraverseCode g) => TraverseCode (FSum.Sum f g)
instance Lift a => TraverseCode (Const a)

instance TraverseCode V1
instance TraverseCode U1
instance (TraverseCode f, TraverseCode g) => TraverseCode (f :*: g)
instance (TraverseCode f, TraverseCode g) => TraverseCode (f :+: g)
instance TraverseCode f => TraverseCode (M1 i c f)
instance TraverseCode Par1
instance Lift a => TraverseCode (K1 i a)
instance (TraverseCode f, TraverseCode g) => TraverseCode (f :.: g)
instance (TraverseCode f, TraverseCode g) => TraverseCode (Compose.Compose f g)
instance TraverseCode f => TraverseCode (MP1 m f)
instance TraverseCode f => TraverseCode (GHCGenerics.Rec1 f)
instance (TraverseCode f, TraverseCode g) => TraverseCode (f GHCGenerics.:.: g)

-- The Elem instance isn't needed for the Seq instance
instance TraverseCode Seq.Elem
instance TraverseCode Seq.Digit
instance TraverseCode Seq.Node
instance TraverseCode Seq.FingerTree
instance TraverseCode Seq.Seq where
  -- This wonky way of doing it makes for a more compact
  -- splice.
  traverseCode f s = [|| coerceFT $$(traverseCode f ft') ||]
    where
      ft' = coerceSeq (Seq.zipWith (flip const) (Seq.replicate (Seq.length s) ()) s)

coerceFT :: Seq.FingerTree a -> Seq.Seq a
coerceFT = coerce
coerceSeq :: Seq.Seq a -> Seq.FingerTree a
coerceSeq = coerce

instance TraverseCode Seq.ViewL
instance TraverseCode Seq.ViewR

instance TraverseCode ZipList
instance TraverseCode Complex.Complex
instance TraverseCode S.First
instance TraverseCode M.First
instance TraverseCode S.Last
instance TraverseCode M.Last
instance TraverseCode S.Min
instance TraverseCode S.Max
instance TraverseCode Ord.Down
instance TraverseCode S.WrappedMonoid
instance TraverseCode S.Dual
instance TraverseCode S.Product
instance TraverseCode S.Sum
instance TraverseCode Solo
instance TraverseCode Tree.Tree
instance TraverseCode NonEmpty.NonEmpty
-- instance TraverseCode TH.TyVarBndr  (Lift Name isn't in base)
instance TraverseCode m => TraverseCode (WrappedMonad m)
instance TraverseCode (p a) => TraverseCode (WrappedArrow p a)
instance TH.Lift a => TraverseCode (S.Arg a)
instance TraverseCode Proxy
instance TraverseCode f => TraverseCode (M.Ap f)
instance TraverseCode f => TraverseCode (M.Alt f)
instance TraverseCode (URec Char)
instance TraverseCode (URec Double)
instance TraverseCode (URec Float)
instance TraverseCode (URec Int)
instance TraverseCode (URec Word)

instance (Ar.Ix i, TH.Lift i) => TraverseCode (Ar.Array i) where
  traverseCode f xs = [|| Ar.listArray bnds $$csc ||]
    where
      csc = traverseCode f (Ar.elems xs)
      bnds = Ar.bounds xs

instance TraverseCode PAr.Array where
  traverseCode f ary = case lst of
      [] -> [|| PAr.emptyArray ||]
      [x] -> [|| pure $$(f x) ||]
      x : xs -> [|| unsafeArrayFromListN len $$(f x) $$(traverseCode f xs) ||]
    where
      len = length ary
      lst = toList ary

instance TraverseCode PSmAr.SmallArray where
  traverseCode f ary = case lst of
      [] -> [|| PSmAr.emptySmallArray ||]
      [x] -> [|| pure $$(f x) ||]
      x : xs -> [|| unsafeSmallArrayFromListN len $$(f x) $$(traverseCode f xs) ||]
    where
      len = length ary
      lst = toList ary

-- | Strictly create an array from a nonempty list (represented as
-- a first element and a list of the rest) of a known length. If the length
-- of the list does not match the given length, this makes demons fly
-- out of your nose.
unsafeArrayFromListN :: Int -> a -> [a] -> PAr.Array a
unsafeArrayFromListN n y ys =
  PAr.createArray n y $ \ma ->
    let go !_ix [] = pure ()
        go !ix (x : xs) = do
            PAr.writeArray ma ix x
            go (ix+1) xs
    in go 1 ys

-- | Strictly create an array from a nonempty list (represented as
-- a first element and a list of the rest) of a known length. If the length
-- of the list does not match the given length, this makes demons fly
-- out of your nose.
unsafeSmallArrayFromListN :: Int -> a -> [a] -> PSmAr.SmallArray a
unsafeSmallArrayFromListN n y ys =
  PSmAr.createSmallArray n y $ \ma ->
    let go !_ix [] = pure ()
        go !ix (x : xs) = do
            PSmAr.writeSmallArray ma ix x
            go (ix+1) xs
    in go 1 ys


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}

module Protolude (
  module X,
  module Base,
  identity,
  map,
  uncons,
  unsnoc,
  applyN,
  print,
  throwIO,
  throwTo,
  show,
  pass,
  guarded,
  guardedA,
  LText,
  LByteString,
  liftIO1,
  liftIO2,
#if !MIN_VERSION_base(4,8,0)
  (&),
  scanl',
#endif
  die,
) where

-- Protolude module exports.
import Debug as X
import Protolude.List as X
import Protolude.Show as X
import Protolude.Bool as X
import Protolude.Monad as X
import Protolude.Functor as X
import Protolude.Either as X
import Protolude.Applicative as X
import Protolude.Conv as X
import Protolude.Panic as X
import Protolude.Exceptions as X
import Protolude.Semiring as X

import Protolude.Base as Base hiding (
    putStr           -- Overriden by Show.putStr
  , putStrLn         -- Overriden by Show.putStrLn
  , print            -- Overriden by Protolude.print
  , show             -- Overriden by Protolude.show
  , showFloat        -- Custom Show instances deprecated.
  , showList         -- Custom Show instances deprecated.
  , showSigned       -- Custom Show instances deprecated.
  , showSignedFloat  -- Custom Show instances deprecated.
  , showsPrec        -- Custom Show instances deprecated.
  )
import qualified Protolude.Base as PBase

-- Used for 'show', not exported.
import Data.String (String)
import Data.String as X (IsString)

-- Maybe'ized version of partial functions
import Protolude.Safe as X (
    headMay
  , headDef
  , initMay
  , initDef
  , initSafe
  , tailMay
  , tailDef
  , tailSafe
  , lastDef
  , lastMay
  , foldr1May
  , foldl1May
  , foldl1May'
  , maximumMay
  , minimumMay
  , maximumDef
  , minimumDef
  , atMay
  , atDef
  )

-- Applicatives
import Control.Applicative as X (
    Applicative(..)
  , Alternative(..)
  , Const(..)
  , ZipList(..)
  , (<**>)
  , liftA
  , liftA2
  , liftA3
  , optional
  )

-- Base typeclasses
import Data.Eq as X (
    Eq(..)
  )
import Data.Ord as X (
    Ord(..)
  , Ordering(..)
  , Down(..)
  , comparing
  )
import Data.Traversable as X
import Data.Foldable as X hiding (
    foldr1
  , foldl1
  , product
  , sum
  )
import Data.Functor.Identity as X (
    Identity(..)
  )

#if MIN_VERSION_base(4,9,0)
import Data.List.NonEmpty as X (
    NonEmpty(..)
  , nonEmpty
  )
import Data.Semigroup as X (
    Semigroup(sconcat, stimes)
  , WrappedMonoid
  , Option(..)
  , option
  , diff
  , cycle1
  , stimesMonoid
  , stimesIdempotent
  , stimesIdempotentMonoid
  , mtimesDefault
  )
#endif

import Data.Monoid as X

#if !MIN_VERSION_base(4,8,0)
import Protolude.Bifunctor as X (Bifunctor(..))
#else
import Data.Bifunctor as X (Bifunctor(..))
#endif

-- Deepseq
import Control.DeepSeq as X (
    NFData(..)
  , ($!!)
  , deepseq
  , force
  )

-- Data structures
import Data.Tuple as X (
    fst
  , snd
  , curry
  , uncurry
  , swap
  )

import Data.List as X (
    splitAt
  , break
  , intercalate
  , isPrefixOf
  , drop
  , filter
  , reverse
  , replicate
  , take
  , sortBy
  , sort
  , intersperse
  , transpose
  , subsequences
  , permutations
  , scanl
#if MIN_VERSION_base(4,8,0)
  , scanl'
#endif
  , scanr
  , iterate
  , repeat
  , cycle
  , unfoldr
  , takeWhile
  , dropWhile
  , group
  , inits
  , tails
  , zipWith
  , zip
  , unzip
  , genericLength
  , genericTake
  , genericDrop
  , genericSplitAt
  , genericReplicate
  )

#if !MIN_VERSION_base(4,8,0)
-- These imports are required for the scanl' rewrite rules
import GHC.Exts (build)
import Data.List (tail)
#endif

-- Hashing
import Data.Hashable as X (
    Hashable
  , hash
  , hashWithSalt
  , hashUsing
  )

import Data.Map as X (Map)
import Data.Set as X (Set)
import Data.Sequence as X (Seq)
import Data.IntMap as X (IntMap)
import Data.IntSet as X (IntSet)

#if MIN_VERSION_base(4,7,0)
import Data.Proxy as X (
    Proxy(..)
  )

import Data.Typeable as X (
    TypeRep
  , Typeable
  , typeRep
  , cast
  , eqT
  )

import Data.Type.Coercion as X (
    Coercion(..)
  , coerceWith
  , repr
  )

import Data.Type.Equality as X (
    (:~:)(..)
  , type (==)
  , sym
  , trans
  , castWith
  , gcastWith
  )

#endif

#if MIN_VERSION_base(4,8,0)
import Data.Void as X (
    Void
  , absurd
  , vacuous
  )
#endif

-- Monad transformers
import Control.Monad.State as X (
    MonadState
  , State
  , StateT(StateT)
  , put
  , get
  , gets
  , modify
  , state
  , withState

  , runState
  , execState
  , evalState

  , runStateT
  , execStateT
  , evalStateT
  )

import Control.Monad.Reader as X (
    MonadReader
  , Reader
  , ReaderT(ReaderT)
  , ask
  , asks
  , local
  , reader
  , runReader
  , runReaderT
  )

import Control.Monad.Trans.Except as X (
    throwE
  , catchE
  )

import Control.Monad.Except as X (
    MonadError
  , Except
  , ExceptT(ExceptT)
  , throwError
  , catchError
  , runExcept
  , runExceptT
  , mapExcept
  , mapExceptT
  , withExcept
  , withExceptT
  )

import Control.Monad.Trans as X (
    MonadIO
  , lift
  , liftIO
  )

-- Base types
import Data.Int as X (
    Int
  , Int8
  , Int16
  , Int32
  , Int64
  )
import Data.Bits as X hiding (
    unsafeShiftL
  , unsafeShiftR
  )
import Data.Word as X (
    Word
  , Word8
  , Word16
  , Word32
  , Word64
#if MIN_VERSION_base(4,7,0)
  , byteSwap16
  , byteSwap32
  , byteSwap64
#endif
  )

import Data.Either as X (
    Either(..)
  , either
  , lefts
  , rights
  , partitionEithers
#if MIN_VERSION_base(4,7,0)
  , isLeft
  , isRight
#endif
  )

import Data.Complex as X (
    Complex(..)
  , realPart
  , imagPart
  , mkPolar
  , cis
  , polar
  , magnitude
  , phase
  , conjugate
  )
import Data.Char as X (chr)
import Data.Bool as X hiding (bool)
import Data.Maybe as X hiding (fromJust)

import Data.Function as X (
    const
  , (.)
  , ($)
  , flip
  , fix
  , on
#if MIN_VERSION_base(4,8,0)
  , (&)
#endif
  )

-- Genericss
import GHC.Generics as X (
    Generic(..)
  , Generic1
  , Rep
  , K1(..)
  , M1(..)
  , U1(..)
  , V1
  , D1
  , C1
  , S1
  , (:+:)(..)
  , (:*:)(..)
  , (:.:)(..)
  , Rec0
  , Constructor(..)
  , Datatype(..)
  , Selector(..)
  , Fixity(..)
  , Associativity(..)
#if ( __GLASGOW_HASKELL__ >= 800 )
  , Meta(..)
  , FixityI(..)
  , URec
#endif
  )

-- ByteString
import qualified Data.ByteString.Lazy
import Data.ByteString as X (ByteString)

-- Text
import Data.Text as X (
    Text
  , lines
  , words
  , unlines
  , unwords
  )
import qualified Data.Text.Lazy

import Data.Text.IO as X (
    getLine
  , getContents
  , interact
  , readFile
  , writeFile
  , appendFile
  )

import Data.Text.Lazy as X (
    toStrict
  , fromStrict
  )

import Data.Text.Encoding as X (
    encodeUtf8
  , decodeUtf8
  , decodeUtf8'
  , decodeUtf8With
  )

import Data.Text.Encoding.Error as X (
    OnDecodeError
  , OnError
  , UnicodeException
  , lenientDecode
  , strictDecode
  , ignore
  , replace
  )

-- IO
import System.Environment as X (getArgs)
import qualified System.Exit
import System.Exit as X (
    ExitCode(..)
  , exitWith
  , exitFailure
  , exitSuccess
  )
import System.IO as X (
    Handle
  , FilePath
  , IOMode(..)
  , stdin
  , stdout
  , stderr
  , withFile
  , openFile
  )

-- ST
import Control.Monad.ST as X (
    ST
  , runST
  , fixST
  )

-- Concurrency and Parallelism
import Control.Exception as X hiding (
    throw    -- Impure throw is forbidden.
  , throwIO
  , throwTo
  , assert
  , Handler(..)
  )

import qualified Control.Exception

import Control.Monad.STM as X (
    STM
  , atomically
#if !(MIN_VERSION_stm(2,5,0))
  , always
  , alwaysSucceeds
#endif
  , retry
  , orElse
  , check
  , throwSTM
  , catchSTM
  )
import Control.Concurrent as X hiding (
    throwTo
  , yield
  )
import Control.Concurrent.Async as X (
    Async(..)
  , Concurrently(..)
  , async
  , asyncBound
  , asyncOn
  , withAsync
  , withAsyncBound
  , withAsyncOn
  , wait
  , poll
  , waitCatch
  , cancel
  , cancelWith
  , asyncThreadId
  , waitAny
  , waitAnyCatch
  , waitAnyCancel
  , waitAnyCatchCancel
  , waitEither
  , waitEitherCatch
  , waitEitherCancel
  , waitEitherCatchCancel
  , waitEither_
  , waitBoth
  , link
  , link2
  , race
  , race_
  , concurrently
  )

import Foreign.Ptr as X (IntPtr, WordPtr)
import Foreign.Storable as X (Storable)
import Foreign.StablePtr as X (StablePtr)

-- Read instances hiding unsafe builtins (read)
import Text.Read as X (
    Read
  , reads
  , readMaybe
  , readEither
  )

-- Type synonymss for lazy texts
type LText = Data.Text.Lazy.Text
type LByteString = Data.ByteString.Lazy.ByteString

#if !MIN_VERSION_base(4,8,0)
infixl 1 &

(&) :: a -> (a -> b) -> b
x & f = f x
#endif

identity :: a -> a
identity x = x

map :: Functor f => (a -> b) -> f a -> f b
map = fmap

uncons :: [a] -> Maybe (a, [a])
uncons [] = Nothing
uncons (x:xs) = Just (x, xs)

unsnoc :: [x] -> Maybe ([x],x)
unsnoc = foldr go Nothing
  where
    go x mxs = Just (case mxs of
       Nothing -> ([], x)
       Just (xs, e) -> (x:xs, e))

applyN :: Int -> (a -> a) -> a -> a
applyN n f = X.foldr (.) identity (X.replicate n f)

print :: (X.MonadIO m, PBase.Show a) => a -> m ()
print = liftIO . PBase.print

throwIO :: (X.MonadIO m, Exception e) => e -> m a
throwIO = liftIO . Control.Exception.throwIO

throwTo :: (X.MonadIO m, Exception e) => ThreadId -> e -> m ()
throwTo tid e = liftIO (Control.Exception.throwTo tid e)

-- | Do nothing returning unit inside applicative.
pass :: Applicative f => f ()
pass = pure ()

guarded :: (Alternative f) => (a -> Bool) -> a -> f a
guarded p x = X.bool empty (pure x) (p x)

guardedA :: (Functor f, Alternative t) => (a -> f Bool) -> a -> f (t a)
guardedA p x = X.bool empty (pure x) <$> p x

-- | Lift an 'IO' operation with 1 argument into another monad
liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b
liftIO1 = (.) liftIO

-- | Lift an 'IO' operation with 2 arguments into another monad
liftIO2 :: MonadIO m => (a -> b -> IO c) -> a -> b -> m c
liftIO2 = ((.).(.)) liftIO

show :: (Show a, StringConv String b) => a -> b
show x = toS (PBase.show x)
{-# SPECIALIZE show :: Show  a => a -> Text  #-}
{-# SPECIALIZE show :: Show  a => a -> LText  #-}
{-# SPECIALIZE show :: Show  a => a -> ByteString  #-}
{-# SPECIALIZE show :: Show  a => a -> LByteString  #-}
{-# SPECIALIZE show :: Show  a => a -> String  #-}

#if MIN_VERSION_base(4,8,0)
die :: Text -> IO a
die err = System.Exit.die (toS err)
#else
die :: Text -> IO a
die err = hPutStrLn stderr err >> exitFailure
#endif

#if !MIN_VERSION_base(4,8,0)
-- This is a literal copy of the implementation in GHC.List in base-4.10.1.0.

-- | A strictly accumulating version of 'scanl'
{-# NOINLINE [1] scanl' #-}
scanl'           :: (b -> a -> b) -> b -> [a] -> [b]
scanl' = scanlGo'
  where
    scanlGo'           :: (b -> a -> b) -> b -> [a] -> [b]
    scanlGo' f !q ls    = q : (case ls of
                            []   -> []
                            x:xs -> scanlGo' f (f q x) xs)

{-# RULES
"scanl'"  [~1] forall f a bs . scanl' f a bs =
  build (\c n -> a `c` foldr (scanlFB' f c) (flipSeqScanl' n) bs a)
"scanlList'" [1] forall f a bs .
    foldr (scanlFB' f (:)) (flipSeqScanl' []) bs a = tail (scanl' f a bs)
 #-}

{-# INLINE [0] scanlFB' #-}
scanlFB' :: (b -> a -> b) -> (b -> c -> c) -> a -> (b -> c) -> b -> c
scanlFB' f c = \b g -> \x -> let !b' = f x b in b' `c` g b'

{-# INLINE [0] flipSeqScanl' #-}
flipSeqScanl' :: a -> b -> a
flipSeqScanl' a !_b = a
#endif


{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}

module CGX.Prelude
  ( module X
#if __GLASGOW_HASKELL__ <= 800
  , fromLeft
  , fromRight
#endif
  , mk
  , ps
  , psu
  ) where

import qualified Data.Text as Text
import qualified Prelude

import Prelude as X
  ( Bounded(..)
  , Enum(..)
  , iterate
  , maxBound
  )

import Control.Applicative as X
  ( Applicative(..)
  , (<$)
  , (<$>)
  , (<*)
  , (*>)
  , pure
  )

import Control.Monad as X
  ( Functor
  , Monad
  , forever
  , fmap
  , liftM
  , return
  , when
  , (>>=)
  , (=<<)
  , (>>)
  )

import Control.Monad.State as X
  ( State
  , get
  , put
  , runState
  )

import Control.Exception.Base as X
  ( SomeException(..)
  , handle
  )

import Control.Concurrent as X

import Debug.Trace as X
  ( trace
  , traceIO
  , traceShow
  )

import Safe as X
  ( headMay
  , abort
  )

import Data.Eq as X
import Data.Ord as X
import Data.Monoid as X
import Data.Traversable as X
import Data.Foldable as X hiding
  ( foldr1
  , foldl1
  , maximum
  , maximumBy
  , minimum
  , minimumBy
  )

import Data.Int as X
import Data.Bits as X
import Data.Word as X
import Data.Bool as X hiding (bool)
import Data.Char as X (Char)
import Data.Maybe as X hiding (fromJust)
import Data.Either as X
--import Data.Complex as X

import Data.Function as X
  ( id
  , const
  , (.)
  , ($)
  , flip
  , fix
  , on
  )

import Data.Tuple as X
import Data.List as X
  ( filter
  , intersect
  , iterate
  , reverse
  , take
  , takeWhile
  , (\\)
  , (++)
  )

import Data.Text as X
  ( Text
  , pack
  )
import qualified Data.Text.Lazy
import qualified Data.Text.IO
import Data.String.Conv as X
  ( toS
  )
import Data.IntMap as X (IntMap)

import Data.Tagged as X

import GHC.IO as X (IO)
import GHC.Num as X
import GHC.Real as X
import GHC.Float as X
import GHC.Generics as X
import GHC.Show as X
import GHC.Exts as X
  ( Constraint
  , Ptr
  , FunPtr
  , the
  )

#if __GLASGOW_HASKELL__ <= 800
fromLeft :: a -> Either a b -> a
fromLeft _ (Left a) = a
fromLeft a _        = a

fromRight :: b -> Either a b -> b
fromRight _ (Right b) = b
fromRight b _         = b
#endif

mk :: a -> Tagged b a
mk = X.Tagged

psu :: Show a => Tagged b a -> Text
psu = Text.pack . show . X.untag

ps :: Show a => a -> Text
ps = Text.pack . show


-- File created: 2009-07-11 21:47:19

-- ScmValue depends on Haschoo
-- Haschoo  depends on Context
-- Context  depends on ScmValue
--
-- Thus they all have to be in the same module, to avoid circular dependencies.
{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-}

module Haschoo.Types
   ( Haschoo, runHaschoo, withHaschoo
   , ScmValue(..), MacroCall(..)
   , isTrue, isAggregate
   , toScmString, toScmMString
   , toScmVector
   , pairToList, listToPair
   , Context, mkContext, addToContext, contextLookup, contextSize
   , scmShow, scmShowWith
   ) where

import Control.Applicative        ((<$>))
import Control.Arrow              (second)
import Control.Monad.Error        (ErrorT, MonadError, runErrorT)
import Control.Monad.State.Strict (StateT, MonadState, evalStateT)
import Control.Monad.Trans        (MonadIO, liftIO)
import Data.Array.IO              (IOArray, IOUArray, newListArray, getElems)
import Data.Array.Unboxed         (Array, UArray, elems, listArray)
import Data.Complex               (Complex((:+)))
import Data.IORef                 (IORef, readIORef, newIORef)
import Data.List                  (intercalate)
import Data.Ratio                 (numerator, denominator)
import System.IO                  (Handle)
import System.IO.Unsafe           (unsafeInterleaveIO)
import Text.Show.Functions        ()

import qualified Data.ListTrie.Patricia.Map.Enum as TM
import Data.ListTrie.Patricia.Map.Enum (TrieMap)

import Haschoo.Utils (ErrOr, lazyMapM)

-- Our main monad
newtype Haschoo a = Haschoo (StateT HaschState (ErrorT String IO) a)
   deriving (Functor, Monad, MonadIO, MonadState HaschState, MonadError String)

runHaschoo :: HaschState -> Haschoo a -> IO (ErrOr a)
runHaschoo state (Haschoo h) = runErrorT $ evalStateT h state

-- Like 'local' of the Reader monad
withHaschoo :: HaschState -> Haschoo a -> Haschoo a
withHaschoo state h = either fail return =<< liftIO (runHaschoo state h)

type HaschState = [IORef Context]

data ScmValue = ScmPrim  String !([ScmValue] -> Haschoo   ScmValue)
              | ScmFunc  String !([ScmValue] -> IO (ErrOr ScmValue))

              | ScmMacro String
                   !(MacroCall ->
                        Haschoo (ScmValue, TrieMap Char [IORef Context]))

              | ScmBool       !Bool
              | ScmChar       !Char
              | ScmInt        !Integer
              | ScmRat        !Rational
              | ScmReal       !Double
              | ScmComplex    !(Complex Double)
              | ScmIdentifier !String
              | ScmPair       !(IORef ScmValue) !(IORef ScmValue)
              | ScmString     !(  UArray Int Char)
              | ScmMString    !(IOUArray Int Char)
              | ScmVector     !(   Array Int ScmValue)
              | ScmMVector    !( IOArray Int ScmValue)

              | ScmSyntax { patterns :: ![(ScmValue, ScmValue, [String])]
                          , literals :: ![(String, Maybe ScmValue)] }

              -- These two are only for literal lists, appearing only directly
              -- from the parser
              | ScmList       ![ScmValue]
              | ScmDottedList ![ScmValue] !ScmValue -- The list is never empty

              -- The "unspecified value" returned by IO procedures and such
              | ScmVoid

              | ScmInput  !Handle
              | ScmOutput !Handle
              | ScmEOF

              -- The "environment-specifier" used by eval-related procedures
              | ScmContext ![Context]

-- The form of the macro usage:
--
-- (macro foo bar), (macro foo . bar), or #(macro foo bar)
--
-- The macro keyword is not included regardless of constructor
data MacroCall = MCList   ![ScmValue]
               | MCDotted ![ScmValue] !ScmValue

isTrue, isAggregate :: ScmValue -> Bool
isTrue (ScmBool False) = False
isTrue _               = True

isAggregate (ScmList       _)   = True
isAggregate (ScmDottedList _ _) = True
isAggregate (ScmVector     _)   = True
isAggregate (ScmMVector    _)   = True
isAggregate (ScmPair       _ _) = True
isAggregate _                   = False

-- From ScmPair to Left . ScmDottedList or Right . ScmList
pairToList :: ScmValue -> IO (Either ScmValue ScmValue)
pairToList = go []
 where
   go xs (ScmList       ys)   =
      return . Right $ ScmList       (reverse xs ++ ys)
   go xs (ScmDottedList ys z) =
      return . Left  $ ScmDottedList (reverse xs ++ ys) z

   go xs (ScmPair a b) = do
      a' <- readIORef a
      b' <- readIORef b
      go (a':xs) b'

   go xs v = return . Left $ ScmDottedList (reverse xs) v

-- ScmList -> ScmPair, returns the tail pointer if it wasn't empty
listToPair :: [ScmValue] -> IO (ScmValue, Maybe (IORef ScmValue))
listToPair []     = return (ScmList [], Nothing)
listToPair (x:xs) = second Just <$> go x xs
 where
   go :: ScmValue -> [ScmValue] -> IO (ScmValue, IORef ScmValue)
   go v [] = do
      a <- newIORef v
      b <- newIORef (ScmList [])
      return (ScmPair a b, b)

   go v (y:ys) = do
      a         <- newIORef v
      (zs, fin) <- go y ys
      b         <- newIORef zs
      return (ScmPair a b, fin)

toScmString :: String -> ScmValue
toScmString s = ScmString $ listArray (0, length s - 1) s

toScmMString :: String -> IO ScmValue
toScmMString s = ScmMString <$> newListArray (0, length s - 1) s

toScmVector :: [ScmValue] -> ScmValue
toScmVector v = ScmVector $ listArray (0, length v - 1) v

newtype Context = Context (TrieMap Char ScmValue)

mkContext :: [(String, ScmValue)] -> Context
mkContext = Context . TM.fromList

addToContext :: String -> ScmValue -> Context -> Context
addToContext name val (Context c) = Context (TM.insert' name val c)

contextLookup :: String -> Context -> Maybe ScmValue
contextLookup s (Context c) = TM.lookup s c

contextSize :: Context -> Int
contextSize (Context c) = TM.size' c

scmShow :: ScmValue -> IO String
scmShow ScmVoid           = return "" -- Has no representation
scmShow (ScmBool b)       = return$ '#' : if b then "t" else "f"
scmShow (ScmPrim s _)     = return s
scmShow (ScmFunc s _)     = return s
scmShow (ScmMacro s _)    = return s
scmShow (ScmIdentifier s) = return s
scmShow (ScmInt n)        = return$ show n
scmShow (ScmReal n)
   | isNaN      n = return "+nan.#"
   | isInfinite n = return$ (if n < 0 then '-' else '+') : "inf.#"
   | otherwise    = return$ show n
scmShow (ScmRat n) =
   if denominator n == 1
      then return$ show (numerator n)
      else return$ concat [show (numerator n), "/", show (denominator n)]

scmShow (ScmComplex (a :+ b)) = do
   bs <- scmShow (ScmReal b)
   as <- scmShow (ScmReal a)
   return$ concat [ as
                  , if head bs `elem` "-+" then [] else "+"
                  , bs
                  , "i" ]

scmShow (ScmChar c) | c == ' '  = return  "#\\space"
                    | c == '\n' = return  "#\\newline"
                    | otherwise = return$ "#\\" ++ [c]

scmShow (ScmSyntax  _ _) = return "<syntax rules>"
scmShow (ScmContext _)   = return "<environment specifier>"
scmShow ScmEOF           = return "<end of file object>"
scmShow (ScmInput  _)    = return "<input port>"
scmShow (ScmOutput _)    = return "<output port>"

scmShow (ScmString  s) = return$ showScmString (elems s)
scmShow (ScmMString s) = showScmString <$> getElems s

scmShow x | isAggregate x = scmShowWith scmShow x
          | otherwise     = error "scmShow :: the impossible happened"

scmShowWith :: (ScmValue -> IO String) -> ScmValue -> IO String
scmShowWith f (ScmList xs)        = showScmList f xs
scmShowWith f (ScmDottedList a b) = do
   as <- showScmList f a
   bs <- f b
   return$ concat [init as, " . ", bs, ")"]

scmShowWith f (ScmVector  v) = ('#':) <$>  showScmList f       (elems v)
scmShowWith f (ScmMVector v) = ('#':) <$> (showScmList f =<< getElems v)

scmShowWith f (ScmPair car cdr) = do
   a  <- readIORef car
   as <- f a
   ('(':) . (as ++) <$> unsafeInterleaveIO (readIORef cdr >>= go)
 where
   go   (ScmList [])        = return ")"
   go x@(ScmList _)         = (' ':) . tail <$> f x
   go x@(ScmDottedList _ _) = (' ':) . tail <$> f x

   go (ScmPair x y) = do
      a <- readIORef x
      as <- f a
      (' ':) . (as ++) <$> unsafeInterleaveIO (readIORef y >>= go)

   go x = (" . "++) . (++")") <$> f x

scmShowWith _ _ = error "scmShowWith :: the impossible happened"

showScmString :: String -> String
showScmString s = '"' : foldr ((.) . f) id s "\""
 where
   f c | c == '\\' = showString "\\\\"
       | c == '\"' = showString "\\\""
       | otherwise = showChar c

showScmList :: (a -> IO String) -> [a] -> IO String
showScmList f xs =
   ("("++) . (++")") . intercalate " " <$> lazyMapM f xs


module AsciiString.Prelude
(
  module Exports,
  Product2(..),
  Product3(..),
  Product4(..),
  showBits,
)
where

-- base
-------------------------
import Control.Applicative as Exports
import Control.Arrow as Exports
import Control.Category as Exports
import Control.Concurrent as Exports
import Control.Exception as Exports
import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)
import Control.Monad.IO.Class as Exports
import Control.Monad.Fix as Exports hiding (fix)
import Control.Monad.ST as Exports
import Data.Bits as Exports
import Data.Bool as Exports
import Data.Char as Exports
import Data.Coerce as Exports
import Data.Complex as Exports
import Data.Data as Exports
import Data.Dynamic as Exports
import Data.Either as Exports
import Data.Fixed as Exports
import Data.Foldable as Exports
import Data.Function as Exports hiding (id, (.))
import Data.Functor as Exports
import Data.Functor.Identity as Exports
import Data.Int as Exports
import Data.IORef as Exports
import Data.Ix as Exports
import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')
import Data.Maybe as Exports
import Data.Monoid as Exports hiding (Last(..), First(..), (<>))
import Data.Ord as Exports
import Data.Proxy as Exports
import Data.Ratio as Exports
import Data.Semigroup as Exports
import Data.STRef as Exports
import Data.String as Exports
import Data.Traversable as Exports
import Data.Tuple as Exports
import Data.Unique as Exports
import Data.Version as Exports
import Data.Word as Exports
import Debug.Trace as Exports
import Foreign as Exports hiding (void)
import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)
import GHC.Exts as Exports (lazy, inline, sortWith, groupWith)
import GHC.Generics as Exports (Generic)
import GHC.IO.Exception as Exports
import Numeric as Exports
import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.))
import System.Environment as Exports
import System.Exit as Exports
import System.IO as Exports
import System.IO.Error as Exports
import System.IO.Unsafe as Exports
import System.Mem as Exports
import System.Mem.StableName as Exports
import System.Timeout as Exports
import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)
import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)
import Text.Printf as Exports (printf, hPrintf)
import Text.Read as Exports (Read(..), readMaybe, readEither)
import Unsafe.Coerce as Exports

-- bytestring
-------------------------
import Data.ByteString as Exports (ByteString)
import Data.ByteString.Short as Exports (ShortByteString)

-- primitive
-------------------------
import Data.Primitive.PrimArray as Exports hiding (sizeOf, alignment)

-- cereal
-------------------------
import Data.Serialize as Exports

-- foldl
-------------------------
import Control.Foldl as Exports (Fold(..), FoldM(..))

-- deferred-folds
-------------------------
import DeferredFolds.Unfoldl as Exports (Unfoldl(..))
import DeferredFolds.UnfoldlM as Exports (UnfoldlM(..))
import DeferredFolds.Unfoldr as Exports (Unfoldr(..))

-- hashable
-------------------------
import Data.Hashable as Exports

-- deepseq
-------------------------
import Control.DeepSeq as Exports

data Product2 a b = Product2 !a !b

data Product3 a b c = Product3 !a !b !c

data Product4 a b c d = Product4 !a !b !c !d

showBits :: forall a. (Integral a, Show a, FiniteBits a) => a -> String
showBits = padL (finiteBitSize (undefined :: a)) '0' . ($ "") . showIntAtBase 2 intToDigit

padL :: Int -> Char -> String -> String
padL n c s
    | length s < n  = s ++ replicate (n - length s) c
    | otherwise     = s