{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE DeriveFunctor #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.ParserCombinators.ReadP
-- Copyright   :  (c) The University of Glasgow 2002
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  non-portable (local universal quantification)
--
-- This is a library of parser combinators, originally written by Koen Claessen.
-- It parses all alternatives in parallel, so it never keeps hold of
-- the beginning of the input string, a common source of space leaks with
-- other parsers.  The @('+++')@ choice combinator is genuinely commutative;
-- it makes no difference which branch is \"shorter\".

-----------------------------------------------------------------------------

module Text.ParserCombinators.ReadP
  (
  -- * The 'ReadP' type
  ReadP,

  -- * Primitive operations
  get,
  look,
  (+++),
  (<++),
  gather,

  -- * Other operations
  pfail,
  eof,
  satisfy,
  char,
  string,
  munch,
  munch1,
  skipSpaces,
  choice,
  count,
  between,
  option,
  optional,
  many,
  many1,
  skipMany,
  skipMany1,
  sepBy,
  sepBy1,
  endBy,
  endBy1,
  chainr,
  chainl,
  chainl1,
  chainr1,
  manyTill,

  -- * Running a parser
  ReadS,
  readP_to_S,
  readS_to_P,

  -- * Properties
  -- $properties
  )
 where

import GHC.Unicode ( isSpace )
import GHC.List ( replicate, null )
import GHC.Base hiding ( many )

import Control.Monad.Fail

infixr 5 +++, <++

------------------------------------------------------------------------
-- ReadS

-- | A parser for a type @a@, represented as a function that takes a
-- 'String' and returns a list of possible parses as @(a,'String')@ pairs.
--
-- Note that this kind of backtracking parser is very inefficient;
-- reading a large structure may be quite slow (cf 'ReadP').
type ReadS a = String -> [(a,String)]

-- ---------------------------------------------------------------------------
-- The P type
-- is representation type -- should be kept abstract

data P a
  = Get (Char -> P a)
  | Look (String -> P a)
  | Fail
  | Result a (P a)
  | Final (NonEmpty (a,String))
  deriving Functor -- ^ @since 4.8.0.0

-- Monad, MonadPlus

-- | @since 4.5.0.0
instance Applicative P where
  pure x = Result x Fail
  (<*>) = ap

-- | @since 2.01
instance MonadPlus P

-- | @since 2.01
instance Monad P where
  (Get f)         >>= k = Get (\c -> f c >>= k)
  (Look f)        >>= k = Look (\s -> f s >>= k)
  Fail            >>= _ = Fail
  (Result x p)    >>= k = k x <|> (p >>= k)
  (Final (r:|rs)) >>= k = final [ys' | (x,s) <- (r:rs), ys' <- run (k x) s]

  fail _ = Fail

-- | @since 4.9.0.0
instance MonadFail P where
  fail _ = Fail

-- | @since 4.5.0.0
instance Alternative P where
  empty = Fail

  -- most common case: two gets are combined
  Get f1     <|> Get f2     = Get (\c -> f1 c <|> f2 c)

  -- results are delivered as soon as possible
  Result x p <|> q          = Result x (p <|> q)
  p          <|> Result x q = Result x (p <|> q)

  -- fail disappears
  Fail       <|> p          = p
  p          <|> Fail       = p

  -- two finals are combined
  -- final + look becomes one look and one final (=optimization)
  -- final + sthg else becomes one look and one final
  Final r       <|> Final t = Final (r <> t)
  Final (r:|rs) <|> Look f  = Look (\s -> Final (r:|(rs ++ run (f s) s)))
  Final (r:|rs) <|> p       = Look (\s -> Final (r:|(rs ++ run p s)))
  Look f        <|> Final r = Look (\s -> Final (case run (f s) s of
                                []     -> r
                                (x:xs) -> (x:|xs) <> r))
  p             <|> Final r = Look (\s -> Final (case run p s of
                                []     -> r
                                (x:xs) -> (x:|xs) <> r))

  -- two looks are combined (=optimization)
  -- look + sthg else floats upwards
  Look f     <|> Look g     = Look (\s -> f s <|> g s)
  Look f     <|> p          = Look (\s -> f s <|> p)
  p          <|> Look f     = Look (\s -> p <|> f s)

-- ---------------------------------------------------------------------------
-- The ReadP type

newtype ReadP a = R (forall b . (a -> P b) -> P b)

-- | @since 2.01
instance Functor ReadP where
  fmap h (R f) = R (\k -> f (k . h))

-- | @since 4.6.0.0
instance Applicative ReadP where
    pure x = R (\k -> k x)
    (<*>) = ap
    -- liftA2 = liftM2

-- | @since 2.01
instance Monad ReadP where
  fail _    = R (\_ -> Fail)
  R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))

-- | @since 4.9.0.0
instance MonadFail ReadP where
  fail _    = R (\_ -> Fail)

-- | @since 4.6.0.0
instance Alternative ReadP where
  empty = pfail
  (<|>) = (+++)

-- | @since 2.01
instance MonadPlus ReadP

-- ---------------------------------------------------------------------------
-- Operations over P

final :: [(a,String)] -> P a
final []     = Fail
final (r:rs) = Final (r:|rs)

run :: P a -> ReadS a
run (Get f)         (c:s) = run (f c) s
run (Look f)        s     = run (f s) s
run (Result x p)    s     = (x,s) : run p s
run (Final (r:|rs)) _     = (r:rs)
run _               _     = []

-- ---------------------------------------------------------------------------
-- Operations over ReadP

get :: ReadP Char
-- ^ Consumes and returns the next character.
--   Fails if there is no input left.
get = R Get

look :: ReadP String
-- ^ Look-ahead: returns the part of the input that is left, without
--   consuming it.
look = R Look

pfail :: ReadP a
-- ^ Always fails.
pfail = R (\_ -> Fail)

(+++) :: ReadP a -> ReadP a -> ReadP a
-- ^ Symmetric choice.
R f1 +++ R f2 = R (\k -> f1 k <|> f2 k)

(<++) :: ReadP a -> ReadP a -> ReadP a
-- ^ Local, exclusive, left-biased choice: If left parser
--   locally produces any result at all, then right parser is
--   not used.
R f0 <++ q =
  do s <- look
     probe (f0 return) s 0#
 where
  probe (Get f)        (c:s) n = probe (f c) s (n+#1#)
  probe (Look f)       s     n = probe (f s) s n
  probe p@(Result _ _) _     n = discard n >> R (p >>=)
  probe (Final r)      _     _ = R (Final r >>=)
  probe _              _     _ = q

  discard 0# = return ()
  discard n  = get >> discard (n-#1#)

gather :: ReadP a -> ReadP (String, a)
-- ^ Transforms a parser into one that does the same, but
--   in addition returns the exact characters read.
--   IMPORTANT NOTE: 'gather' gives a runtime error if its first argument
--   is built using any occurrences of readS_to_P.
gather (R m)
  = R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))
 where
  gath :: (String -> String) -> P (String -> P b) -> P b
  gath l (Get f)      = Get (\c -> gath (l.(c:)) (f c))
  gath _ Fail         = Fail
  gath l (Look f)     = Look (\s -> gath l (f s))
  gath l (Result k p) = k (l []) <|> gath l p
  gath _ (Final _)    = errorWithoutStackTrace "do not use readS_to_P in gather!"

-- ---------------------------------------------------------------------------
-- Derived operations

satisfy :: (Char -> Bool) -> ReadP Char
-- ^ Consumes and returns the next character, if it satisfies the
--   specified predicate.
satisfy p = do c <- get; if p c then return c else pfail

char :: Char -> ReadP Char
-- ^ Parses and returns the specified character.
char c = satisfy (c ==)

eof :: ReadP ()
-- ^ Succeeds iff we are at the end of input
eof = do { s <- look
         ; if null s then return ()
                     else pfail }

string :: String -> ReadP String
-- ^ Parses and returns the specified string.
string this = do s <- look; scan this s
 where
  scan []     _               = do return this
  scan (x:xs) (y:ys) | x == y = do _ <- get; scan xs ys
  scan _      _               = do pfail

munch :: (Char -> Bool) -> ReadP String
-- ^ Parses the first zero or more characters satisfying the predicate.
--   Always succeeds, exactly once having consumed all the characters
--   Hence NOT the same as (many (satisfy p))
munch p =
  do s <- look
     scan s
 where
  scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s)
  scan _            = do return ""

munch1 :: (Char -> Bool) -> ReadP String
-- ^ Parses the first one or more characters satisfying the predicate.
--   Fails if none, else succeeds exactly once having consumed all the characters
--   Hence NOT the same as (many1 (satisfy p))
munch1 p =
  do c <- get
     if p c then do s <- munch p; return (c:s)
            else pfail

choice :: [ReadP a] -> ReadP a
-- ^ Combines all parsers in the specified list.
choice []     = pfail
choice [p]    = p
choice (p:ps) = p +++ choice ps

skipSpaces :: ReadP ()
-- ^ Skips all whitespace.
skipSpaces =
  do s <- look
     skip s
 where
  skip (c:s) | isSpace c = do _ <- get; skip s
  skip _                 = do return ()

count :: Int -> ReadP a -> ReadP [a]
-- ^ @count n p@ parses @n@ occurrences of @p@ in sequence. A list of
--   results is returned.
count n p = sequence (replicate n p)

between :: ReadP open -> ReadP close -> ReadP a -> ReadP a
-- ^ @between open close p@ parses @open@, followed by @p@ and finally
--   @close@. Only the value of @p@ is returned.
between open close p = do _ <- open
                          x <- p
                          _ <- close
                          return x

option :: a -> ReadP a -> ReadP a
-- ^ @option x p@ will either parse @p@ or return @x@ without consuming
--   any input.
option x p = p +++ return x

optional :: ReadP a -> ReadP ()
-- ^ @optional p@ optionally parses @p@ and always returns @()@.
optional p = (p >> return ()) +++ return ()

many :: ReadP a -> ReadP [a]
-- ^ Parses zero or more occurrences of the given parser.
many p = return [] +++ many1 p

many1 :: ReadP a -> ReadP [a]
-- ^ Parses one or more occurrences of the given parser.
many1 p = liftM2 (:) p (many p)

skipMany :: ReadP a -> ReadP ()
-- ^ Like 'many', but discards the result.
skipMany p = many p >> return ()

skipMany1 :: ReadP a -> ReadP ()
-- ^ Like 'many1', but discards the result.
skipMany1 p = p >> skipMany p

sepBy :: ReadP a -> ReadP sep -> ReadP [a]
-- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.
--   Returns a list of values returned by @p@.
sepBy p sep = sepBy1 p sep +++ return []

sepBy1 :: ReadP a -> ReadP sep -> ReadP [a]
-- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.
--   Returns a list of values returned by @p@.
sepBy1 p sep = liftM2 (:) p (many (sep >> p))

endBy :: ReadP a -> ReadP sep -> ReadP [a]
-- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended
--   by @sep@.
endBy p sep = many (do x <- p ; _ <- sep ; return x)

endBy1 :: ReadP a -> ReadP sep -> ReadP [a]
-- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended
--   by @sep@.
endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x)

chainr :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
-- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.
--   Returns a value produced by a /right/ associative application of all
--   functions returned by @op@. If there are no occurrences of @p@, @x@ is
--   returned.
chainr p op x = chainr1 p op +++ return x

chainl :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
-- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.
--   Returns a value produced by a /left/ associative application of all
--   functions returned by @op@. If there are no occurrences of @p@, @x@ is
--   returned.
chainl p op x = chainl1 p op +++ return x

chainr1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
-- ^ Like 'chainr', but parses one or more occurrences of @p@.
chainr1 p op = scan
  where scan   = p >>= rest
        rest x = do f <- op
                    y <- scan
                    return (f x y)
                 +++ return x

chainl1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
-- ^ Like 'chainl', but parses one or more occurrences of @p@.
chainl1 p op = p >>= rest
  where rest x = do f <- op
                    y <- p
                    rest (f x y)
                 +++ return x

manyTill :: ReadP a -> ReadP end -> ReadP [a]
-- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@
--   succeeds. Returns a list of values returned by @p@.
manyTill p end = scan
  where scan = (end >> return []) <++ (liftM2 (:) p scan)

-- ---------------------------------------------------------------------------
-- Converting between ReadP and Read

readP_to_S :: ReadP a -> ReadS a
-- ^ Converts a parser into a Haskell ReadS-style function.
--   This is the main way in which you can \"run\" a 'ReadP' parser:
--   the expanded type is
-- @ readP_to_S :: ReadP a -> String -> [(a,String)] @
readP_to_S (R f) = run (f return)

readS_to_P :: ReadS a -> ReadP a
-- ^ Converts a Haskell ReadS-style function into a parser.
--   Warning: This introduces local backtracking in the resulting
--   parser, and therefore a possible inefficiency.
readS_to_P r =
  R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))

-- ---------------------------------------------------------------------------
-- QuickCheck properties that hold for the combinators

{- $properties
The following are QuickCheck specifications of what the combinators do.
These can be seen as formal specifications of the behavior of the
combinators.

For some values, we only care about the lists contents, not their order,

> (=~) :: Ord a => [a] -> [a] -> Bool
> xs =~ ys = sort xs == sort ys

Here follow the properties:

>>> readP_to_S get []
[]

prop> \c str -> readP_to_S get (c:str) == [(c, str)]

prop> \str -> readP_to_S look str == [(str, str)]

prop> \str -> readP_to_S pfail str == []

prop> \x str -> readP_to_S (return x) s == [(x,s)]

> prop_Bind p k s =
>    readP_to_S (p >>= k) s =~
>      [ ys''
>      | (x,s') <- readP_to_S p s
>      , ys''   <- readP_to_S (k (x::Int)) s'
>      ]

> prop_Plus p q s =
>   readP_to_S (p +++ q) s =~
>     (readP_to_S p s ++ readP_to_S q s)

> prop_LeftPlus p q s =
>   readP_to_S (p <++ q) s =~
>     (readP_to_S p s +<+ readP_to_S q s)
>  where
>   [] +<+ ys = ys
>   xs +<+ _  = xs

> prop_Gather s =
>   forAll readPWithoutReadS $ \p ->
>     readP_to_S (gather p) s =~
>       [ ((pre,x::Int),s')
>       | (x,s') <- readP_to_S p s
>       , let pre = take (length s - length s') s
>       ]

prop> \this str -> readP_to_S (string this) (this ++ str) == [(this,str)]

> prop_String_Maybe this s =
>   readP_to_S (string this) s =~
>     [(this, drop (length this) s) | this `isPrefixOf` s]

> prop_Munch p s =
>   readP_to_S (munch p) s =~
>     [(takeWhile p s, dropWhile p s)]

> prop_Munch1 p s =
>   readP_to_S (munch1 p) s =~
>     [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)]

> prop_Choice ps s =
>   readP_to_S (choice ps) s =~
>     readP_to_S (foldr (+++) pfail ps) s

> prop_ReadS r s =
>   readP_to_S (readS_to_P r) s =~ r s
-}


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.ParserCombinators.ReadPrec
-- Copyright   :  (c) The University of Glasgow 2002
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  non-portable (uses Text.ParserCombinators.ReadP)
--
-- This library defines parser combinators for precedence parsing.

-----------------------------------------------------------------------------

module Text.ParserCombinators.ReadPrec
  (
  ReadPrec,

  -- * Precedences
  Prec,
  minPrec,

  -- * Precedence operations
  lift,
  prec,
  step,
  reset,

  -- * Other operations
  -- | All are based directly on their similarly-named 'ReadP' counterparts.
  get,
  look,
  (+++),
  (<++),
  pfail,
  choice,

  -- * Converters
  readPrec_to_P,
  readP_to_Prec,
  readPrec_to_S,
  readS_to_Prec,
  )
 where

import Text.ParserCombinators.ReadP
  ( ReadP
  , ReadS
  , readP_to_S
  , readS_to_P
  )

import qualified Text.ParserCombinators.ReadP as ReadP
  ( get
  , look
  , (+++), (<++)
  , pfail
  )

import GHC.Num( Num(..) )
import GHC.Base

import qualified Control.Monad.Fail as MonadFail

-- ---------------------------------------------------------------------------
-- The readPrec type

newtype ReadPrec a = P (Prec -> ReadP a)

-- Functor, Monad, MonadPlus

-- | @since 2.01
instance Functor ReadPrec where
  fmap h (P f) = P (\n -> fmap h (f n))

-- | @since 4.6.0.0
instance Applicative ReadPrec where
    pure x  = P (\_ -> pure x)
    (<*>) = ap
    liftA2 = liftM2

-- | @since 2.01
instance Monad ReadPrec where
  fail s    = P (\_ -> fail s)
  P f >>= k = P (\n -> do a <- f n; let P f' = k a in f' n)

-- | @since 4.9.0.0
instance MonadFail.MonadFail ReadPrec where
  fail s    = P (\_ -> MonadFail.fail s)

-- | @since 2.01
instance MonadPlus ReadPrec

-- | @since 4.6.0.0
instance Alternative ReadPrec where
  empty = pfail
  (<|>) = (+++)

-- precedences
type Prec = Int

minPrec :: Prec
minPrec = 0

-- ---------------------------------------------------------------------------
-- Operations over ReadPrec

lift :: ReadP a -> ReadPrec a
-- ^ Lift a precedence-insensitive 'ReadP' to a 'ReadPrec'.
lift m = P (\_ -> m)

step :: ReadPrec a -> ReadPrec a
-- ^ Increases the precedence context by one.
step (P f) = P (\n -> f (n+1))

reset :: ReadPrec a -> ReadPrec a
-- ^ Resets the precedence context to zero.
reset (P f) = P (\_ -> f minPrec)

prec :: Prec -> ReadPrec a -> ReadPrec a
-- ^ @(prec n p)@ checks whether the precedence context is
--   less than or equal to @n@, and
--
--   * if not, fails
--
--   * if so, parses @p@ in context @n@.
prec n (P f) = P (\c -> if c <= n then f n else ReadP.pfail)

-- ---------------------------------------------------------------------------
-- Derived operations

get :: ReadPrec Char
-- ^ Consumes and returns the next character.
--   Fails if there is no input left.
get = lift ReadP.get

look :: ReadPrec String
-- ^ Look-ahead: returns the part of the input that is left, without
--   consuming it.
look = lift ReadP.look

(+++) :: ReadPrec a -> ReadPrec a -> ReadPrec a
-- ^ Symmetric choice.
P f1 +++ P f2 = P (\n -> f1 n ReadP.+++ f2 n)

(<++) :: ReadPrec a -> ReadPrec a -> ReadPrec a
-- ^ Local, exclusive, left-biased choice: If left parser
--   locally produces any result at all, then right parser is
--   not used.
P f1 <++ P f2 = P (\n -> f1 n ReadP.<++ f2 n)

pfail :: ReadPrec a
-- ^ Always fails.
pfail = lift ReadP.pfail

choice :: [ReadPrec a] -> ReadPrec a
-- ^ Combines all parsers in the specified list.
choice ps = foldr (+++) pfail ps

-- ---------------------------------------------------------------------------
-- Converting between ReadPrec and Read

readPrec_to_P :: ReadPrec a -> (Int -> ReadP a)
readPrec_to_P (P f) = f

readP_to_Prec :: (Int -> ReadP a) -> ReadPrec a
readP_to_Prec f = P f

readPrec_to_S :: ReadPrec a -> (Int -> ReadS a)
readPrec_to_S (P f) n = readP_to_S (f n)

readS_to_Prec :: (Int -> ReadS a) -> ReadPrec a
readS_to_Prec f = P (\n -> readS_to_P (f n))


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Read.Lex
-- Copyright   :  (c) The University of Glasgow 2002
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  non-portable (uses Text.ParserCombinators.ReadP)
--
-- The cut-down Haskell lexer, used by Text.Read
--
-----------------------------------------------------------------------------

module Text.Read.Lex
  -- lexing types
  ( Lexeme(..), Number

  , numberToInteger, numberToFixed, numberToRational, numberToRangedRational

  -- lexer
  , lex, expect
  , hsLex
  , lexChar

  , readIntP
  , readOctP
  , readDecP
  , readHexP

  , isSymbolChar
  )
 where

import Text.ParserCombinators.ReadP

import GHC.Base
import GHC.Char
import GHC.Num( Num(..), Integer )
import GHC.Show( Show(..) )
import GHC.Unicode
  ( GeneralCategory(..), generalCategory, isSpace, isAlpha, isAlphaNum )
import GHC.Real( Rational, (%), fromIntegral, Integral,
                 toInteger, (^), quot, even )
import GHC.List
import GHC.Enum( minBound, maxBound )
import Data.Maybe

-- local copy to break import-cycle
-- | @'guard' b@ is @'return' ()@ if @b@ is 'True',
-- and 'mzero' if @b@ is 'False'.
guard           :: (MonadPlus m) => Bool -> m ()
guard True      =  return ()
guard False     =  mzero

-- -----------------------------------------------------------------------------
-- Lexing types

-- ^ Haskell lexemes.
data Lexeme
  = Char   Char         -- ^ Character literal
  | String String       -- ^ String literal, with escapes interpreted
  | Punc   String       -- ^ Punctuation or reserved symbol, e.g. @(@, @::@
  | Ident  String       -- ^ Haskell identifier, e.g. @foo@, @Baz@
  | Symbol String       -- ^ Haskell symbol, e.g. @>>@, @:%@
  | Number Number       -- ^ @since 4.6.0.0
  | EOF
 deriving ( Eq   -- ^ @since 2.01
          , Show -- ^ @since 2.01
          )

-- | @since 4.6.0.0
data Number = MkNumber Int              -- Base
                       Digits           -- Integral part
            | MkDecimal Digits          -- Integral part
                        (Maybe Digits)  -- Fractional part
                        (Maybe Integer) -- Exponent
 deriving ( Eq   -- ^ @since 4.6.0.0
          , Show -- ^ @since 4.6.0.0
          )

-- | @since 4.5.1.0
numberToInteger :: Number -> Maybe Integer
numberToInteger (MkNumber base iPart) = Just (val (fromIntegral base) iPart)
numberToInteger (MkDecimal iPart Nothing Nothing) = Just (val 10 iPart)
numberToInteger _ = Nothing

-- | @since 4.7.0.0
numberToFixed :: Integer -> Number -> Maybe (Integer, Integer)
numberToFixed _ (MkNumber base iPart) = Just (val (fromIntegral base) iPart, 0)
numberToFixed _ (MkDecimal iPart Nothing Nothing) = Just (val 10 iPart, 0)
numberToFixed p (MkDecimal iPart (Just fPart) Nothing)
    = let i = val 10 iPart
          f = val 10 (integerTake p (fPart ++ repeat 0))
          -- Sigh, we really want genericTake, but that's above us in
          -- the hierarchy, so we define our own version here (actually
          -- specialised to Integer)
          integerTake             :: Integer -> [a] -> [a]
          integerTake n _ | n <= 0 = []
          integerTake _ []        =  []
          integerTake n (x:xs)    =  x : integerTake (n-1) xs
      in Just (i, f)
numberToFixed _ _ = Nothing

-- This takes a floatRange, and if the Rational would be outside of
-- the floatRange then it may return Nothing. Not that it will not
-- /necessarily/ return Nothing, but it is good enough to fix the
-- space problems in #5688
-- Ways this is conservative:
-- * the floatRange is in base 2, but we pretend it is in base 10
-- * we pad the floateRange a bit, just in case it is very small
--   and we would otherwise hit an edge case
-- * We only worry about numbers that have an exponent. If they don't
--   have an exponent then the Rational won't be much larger than the
--   Number, so there is no problem
-- | @since 4.5.1.0
numberToRangedRational :: (Int, Int) -> Number
                       -> Maybe Rational -- Nothing = Inf
numberToRangedRational (neg, pos) n@(MkDecimal iPart mFPart (Just exp))
    -- if exp is out of integer bounds,
    -- then the number is definitely out of range
    | exp > fromIntegral (maxBound :: Int) ||
      exp < fromIntegral (minBound :: Int)
    = Nothing
    | otherwise
    = let mFirstDigit = case dropWhile (0 ==) iPart of
                        iPart'@(_ : _) -> Just (length iPart')
                        [] -> case mFPart of
                              Nothing -> Nothing
                              Just fPart ->
                                  case span (0 ==) fPart of
                                  (_, []) -> Nothing
                                  (zeroes, _) ->
                                      Just (negate (length zeroes))
      in case mFirstDigit of
         Nothing -> Just 0
         Just firstDigit ->
             let firstDigit' = firstDigit + fromInteger exp
             in if firstDigit' > (pos + 3)
                then Nothing
                else if firstDigit' < (neg - 3)
                then Just 0
                else Just (numberToRational n)
numberToRangedRational _ n = Just (numberToRational n)

-- | @since 4.6.0.0
numberToRational :: Number -> Rational
numberToRational (MkNumber base iPart) = val (fromIntegral base) iPart % 1
numberToRational (MkDecimal iPart mFPart mExp)
 = let i = val 10 iPart
   in case (mFPart, mExp) of
      (Nothing, Nothing)     -> i % 1
      (Nothing, Just exp)
       | exp >= 0            -> (i * (10 ^ exp)) % 1
       | otherwise           -> i % (10 ^ (- exp))
      (Just fPart, Nothing)  -> fracExp 0   i fPart
      (Just fPart, Just exp) -> fracExp exp i fPart
      -- fracExp is a bit more efficient in calculating the Rational.
      -- Instead of calculating the fractional part alone, then
      -- adding the integral part and finally multiplying with
      -- 10 ^ exp if an exponent was given, do it all at once.

-- -----------------------------------------------------------------------------
-- Lexing

lex :: ReadP Lexeme
lex = skipSpaces >> lexToken

-- | @since 4.7.0.0
expect :: Lexeme -> ReadP ()
expect lexeme = do { skipSpaces
                   ; thing <- lexToken
                   ; if thing == lexeme then return () else pfail }

hsLex :: ReadP String
-- ^ Haskell lexer: returns the lexed string, rather than the lexeme
hsLex = do skipSpaces
           (s,_) <- gather lexToken
           return s

lexToken :: ReadP Lexeme
lexToken = lexEOF     +++
           lexLitChar +++
           lexString  +++
           lexPunc    +++
           lexSymbol  +++
           lexId      +++
           lexNumber

-- ----------------------------------------------------------------------
-- End of file
lexEOF :: ReadP Lexeme
lexEOF = do s <- look
            guard (null s)
            return EOF

-- ---------------------------------------------------------------------------
-- Single character lexemes

lexPunc :: ReadP Lexeme
lexPunc =
  do c <- satisfy isPuncChar
     return (Punc [c])

-- | The @special@ character class as defined in the Haskell Report.
isPuncChar :: Char -> Bool
isPuncChar c = c `elem` ",;()[]{}`"

-- ----------------------------------------------------------------------
-- Symbols

lexSymbol :: ReadP Lexeme
lexSymbol =
  do s <- munch1 isSymbolChar
     if s `elem` reserved_ops then
        return (Punc s)         -- Reserved-ops count as punctuation
      else
        return (Symbol s)
  where
    reserved_ops   = ["..", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"]

isSymbolChar :: Char -> Bool
isSymbolChar c = not (isPuncChar c) && case generalCategory c of
    MathSymbol              -> True
    CurrencySymbol          -> True
    ModifierSymbol          -> True
    OtherSymbol             -> True
    DashPunctuation         -> True
    OtherPunctuation        -> not (c `elem` "'\"")
    ConnectorPunctuation    -> c /= '_'
    _                       -> False
-- ----------------------------------------------------------------------
-- identifiers

lexId :: ReadP Lexeme
lexId = do c <- satisfy isIdsChar
           s <- munch isIdfChar
           return (Ident (c:s))
  where
          -- Identifiers can start with a '_'
    isIdsChar c = isAlpha c || c == '_'
    isIdfChar c = isAlphaNum c || c `elem` "_'"

-- ---------------------------------------------------------------------------
-- Lexing character literals

lexLitChar :: ReadP Lexeme
lexLitChar =
  do _ <- char '\''
     (c,esc) <- lexCharE
     guard (esc || c /= '\'')   -- Eliminate '' possibility
     _ <- char '\''
     return (Char c)

lexChar :: ReadP Char
lexChar = do { (c,_) <- lexCharE; consumeEmpties; return c }
    where
    -- Consumes the string "\&" repeatedly and greedily (will only produce one match)
    consumeEmpties :: ReadP ()
    consumeEmpties = do
        rest <- look
        case rest of
            ('\\':'&':_) -> string "\\&" >> consumeEmpties
            _ -> return ()

lexCharE :: ReadP (Char, Bool)  -- "escaped or not"?
lexCharE =
  do c1 <- get
     if c1 == '\\'
       then do c2 <- lexEsc; return (c2, True)
       else do return (c1, False)
 where
  lexEsc =
    lexEscChar
      +++ lexNumeric
        +++ lexCntrlChar
          +++ lexAscii

  lexEscChar =
    do c <- get
       case c of
         'a'  -> return '\a'
         'b'  -> return '\b'
         'f'  -> return '\f'
         'n'  -> return '\n'
         'r'  -> return '\r'
         't'  -> return '\t'
         'v'  -> return '\v'
         '\\' -> return '\\'
         '\"' -> return '\"'
         '\'' -> return '\''
         _    -> pfail

  lexNumeric =
    do base <- lexBaseChar <++ return 10
       n    <- lexInteger base
       guard (n <= toInteger (ord maxBound))
       return (chr (fromInteger n))

  lexCntrlChar =
    do _ <- char '^'
       c <- get
       case c of
         '@'  -> return '\^@'
         'A'  -> return '\^A'
         'B'  -> return '\^B'
         'C'  -> return '\^C'
         'D'  -> return '\^D'
         'E'  -> return '\^E'
         'F'  -> return '\^F'
         'G'  -> return '\^G'
         'H'  -> return '\^H'
         'I'  -> return '\^I'
         'J'  -> return '\^J'
         'K'  -> return '\^K'
         'L'  -> return '\^L'
         'M'  -> return '\^M'
         'N'  -> return '\^N'
         'O'  -> return '\^O'
         'P'  -> return '\^P'
         'Q'  -> return '\^Q'
         'R'  -> return '\^R'
         'S'  -> return '\^S'
         'T'  -> return '\^T'
         'U'  -> return '\^U'
         'V'  -> return '\^V'
         'W'  -> return '\^W'
         'X'  -> return '\^X'
         'Y'  -> return '\^Y'
         'Z'  -> return '\^Z'
         '['  -> return '\^['
         '\\' -> return '\^\'
         ']'  -> return '\^]'
         '^'  -> return '\^^'
         '_'  -> return '\^_'
         _    -> pfail

  lexAscii =
    do choice
         [ (string "SOH" >> return '\SOH') <++
           (string "SO"  >> return '\SO')
                -- \SO and \SOH need maximal-munch treatment
                -- See the Haskell report Sect 2.6

         , string "NUL" >> return '\NUL'
         , string "STX" >> return '\STX'
         , string "ETX" >> return '\ETX'
         , string "EOT" >> return '\EOT'
         , string "ENQ" >> return '\ENQ'
         , string "ACK" >> return '\ACK'
         , string "BEL" >> return '\BEL'
         , string "BS"  >> return '\BS'
         , string "HT"  >> return '\HT'
         , string "LF"  >> return '\LF'
         , string "VT"  >> return '\VT'
         , string "FF"  >> return '\FF'
         , string "CR"  >> return '\CR'
         , string "SI"  >> return '\SI'
         , string "DLE" >> return '\DLE'
         , string "DC1" >> return '\DC1'
         , string "DC2" >> return '\DC2'
         , string "DC3" >> return '\DC3'
         , string "DC4" >> return '\DC4'
         , string "NAK" >> return '\NAK'
         , string "SYN" >> return '\SYN'
         , string "ETB" >> return '\ETB'
         , string "CAN" >> return '\CAN'
         , string "EM"  >> return '\EM'
         , string "SUB" >> return '\SUB'
         , string "ESC" >> return '\ESC'
         , string "FS"  >> return '\FS'
         , string "GS"  >> return '\GS'
         , string "RS"  >> return '\RS'
         , string "US"  >> return '\US'
         , string "SP"  >> return '\SP'
         , string "DEL" >> return '\DEL'
         ]

-- ---------------------------------------------------------------------------
-- string literal

lexString :: ReadP Lexeme
lexString =
  do _ <- char '"'
     body id
 where
  body f =
    do (c,esc) <- lexStrItem
       if c /= '"' || esc
         then body (f.(c:))
         else let s = f "" in
              return (String s)

  lexStrItem = (lexEmpty >> lexStrItem)
               +++ lexCharE

  lexEmpty =
    do _ <- char '\\'
       c <- get
       case c of
         '&'           -> do return ()
         _ | isSpace c -> do skipSpaces; _ <- char '\\'; return ()
         _             -> do pfail

-- ---------------------------------------------------------------------------
--  Lexing numbers

type Base   = Int
type Digits = [Int]

lexNumber :: ReadP Lexeme
lexNumber
  = lexHexOct  <++      -- First try for hex or octal 0x, 0o etc
                        -- If that fails, try for a decimal number
    lexDecNumber        -- Start with ordinary digits

lexHexOct :: ReadP Lexeme
lexHexOct
  = do  _ <- char '0'
        base <- lexBaseChar
        digits <- lexDigits base
        return (Number (MkNumber base digits))

lexBaseChar :: ReadP Int
-- Lex a single character indicating the base; fail if not there
lexBaseChar = do { c <- get;
                   case c of
                        'o' -> return 8
                        'O' -> return 8
                        'x' -> return 16
                        'X' -> return 16
                        _   -> pfail }

lexDecNumber :: ReadP Lexeme
lexDecNumber =
  do xs    <- lexDigits 10
     mFrac <- lexFrac <++ return Nothing
     mExp  <- lexExp  <++ return Nothing
     return (Number (MkDecimal xs mFrac mExp))

lexFrac :: ReadP (Maybe Digits)
-- Read the fractional part; fail if it doesn't
-- start ".d" where d is a digit
lexFrac = do _ <- char '.'
             fraction <- lexDigits 10
             return (Just fraction)

lexExp :: ReadP (Maybe Integer)
lexExp = do _ <- char 'e' +++ char 'E'
            exp <- signedExp +++ lexInteger 10
            return (Just exp)
 where
   signedExp
     = do c <- char '-' +++ char '+'
          n <- lexInteger 10
          return (if c == '-' then -n else n)

lexDigits :: Int -> ReadP Digits
-- Lex a non-empty sequence of digits in specified base
lexDigits base =
  do s  <- look
     xs <- scan s id
     guard (not (null xs))
     return xs
 where
  scan (c:cs) f = case valDig base c of
                    Just n  -> do _ <- get; scan cs (f.(n:))
                    Nothing -> do return (f [])
  scan []     f = do return (f [])

lexInteger :: Base -> ReadP Integer
lexInteger base =
  do xs <- lexDigits base
     return (val (fromIntegral base) xs)

val :: Num a => a -> Digits -> a
val = valSimple
{-# RULES
"val/Integer" val = valInteger
  #-}
{-# INLINE [1] val #-}

-- The following algorithm is only linear for types whose Num operations
-- are in constant time.
valSimple :: (Num a, Integral d) => a -> [d] -> a
valSimple base = go 0
  where
    go r [] = r
    go r (d : ds) = r' `seq` go r' ds
      where
        r' = r * base + fromIntegral d
{-# INLINE valSimple #-}

-- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b
-- digits are combined into a single radix b^2 digit. This process is
-- repeated until we are left with a single digit. This algorithm
-- performs well only on large inputs, so we use the simple algorithm
-- for smaller inputs.
valInteger :: Integer -> Digits -> Integer
valInteger b0 ds0 = go b0 (length ds0) $ map fromIntegral ds0
  where
    go _ _ []  = 0
    go _ _ [d] = d
    go b l ds
        | l > 40 = b' `seq` go b' l' (combine b ds')
        | otherwise = valSimple b ds
      where
        -- ensure that we have an even number of digits
        -- before we call combine:
        ds' = if even l then ds else 0 : ds
        b' = b * b
        l' = (l + 1) `quot` 2
    combine b (d1 : d2 : ds) = d `seq` (d : combine b ds)
      where
        d = d1 * b + d2
    combine _ []  = []
    combine _ [_] = errorWithoutStackTrace "this should not happen"

-- Calculate a Rational from the exponent [of 10 to multiply with],
-- the integral part of the mantissa and the digits of the fractional
-- part. Leaving the calculation of the power of 10 until the end,
-- when we know the effective exponent, saves multiplications.
-- More importantly, this way we need at most one gcd instead of three.
--
-- frac was never used with anything but Integer and base 10, so
-- those are hardcoded now (trivial to change if necessary).
fracExp :: Integer -> Integer -> Digits -> Rational
fracExp exp mant []
  | exp < 0     = mant % (10 ^ (-exp))
  | otherwise   = fromInteger (mant * 10 ^ exp)
fracExp exp mant (d:ds) = exp' `seq` mant' `seq` fracExp exp' mant' ds
  where
    exp'  = exp - 1
    mant' = mant * 10 + fromIntegral d

valDig :: (Eq a, Num a) => a -> Char -> Maybe Int
valDig 8 c
  | '0' <= c && c <= '7' = Just (ord c - ord '0')
  | otherwise            = Nothing

valDig 10 c = valDecDig c

valDig 16 c
  | '0' <= c && c <= '9' = Just (ord c - ord '0')
  | 'a' <= c && c <= 'f' = Just (ord c - ord 'a' + 10)
  | 'A' <= c && c <= 'F' = Just (ord c - ord 'A' + 10)
  | otherwise            = Nothing

valDig _ _ = errorWithoutStackTrace "valDig: Bad base"

valDecDig :: Char -> Maybe Int
valDecDig c
  | '0' <= c && c <= '9' = Just (ord c - ord '0')
  | otherwise            = Nothing

-- ----------------------------------------------------------------------
-- other numeric lexing functions

readIntP :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
readIntP base isDigit valDigit =
  do s <- munch1 isDigit
     return (val base (map valDigit s))
{-# SPECIALISE readIntP
        :: Integer -> (Char -> Bool) -> (Char -> Int) -> ReadP Integer #-}

readIntP' :: (Eq a, Num a) => a -> ReadP a
readIntP' base = readIntP base isDigit valDigit
 where
  isDigit  c = maybe False (const True) (valDig base c)
  valDigit c = maybe 0     id           (valDig base c)
{-# SPECIALISE readIntP' :: Integer -> ReadP Integer #-}

readOctP, readDecP, readHexP :: (Eq a, Num a) => ReadP a
readOctP = readIntP' 8
readDecP = readIntP' 10
readHexP = readIntP' 16
{-# SPECIALISE readOctP :: ReadP Integer #-}
{-# SPECIALISE readDecP :: ReadP Integer #-}
{-# SPECIALISE readHexP :: ReadP Integer #-}


{-# LANGUAGE Safe #-}
-- This module deliberately declares orphan instances:
{-# OPTIONS_GHC -Wno-orphans #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Show.Functions
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Optional instance of 'Text.Show.Show' for functions:
--
-- > instance Show (a -> b) where
-- >    showsPrec _ _ = showString "<function>"
--
-----------------------------------------------------------------------------

module Text.Show.Functions () where

-- | @since 2.01
instance Show (a -> b) where
        showsPrec _ _ = showString "<function>"


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PatternSynonyms #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Type.Reflection
-- Copyright   :  (c) The University of Glasgow, CWI 2001--2017
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (requires GADTs and compiler support)
--
-- This provides a type-indexed type representation mechanism, similar to that
-- described by,
--
-- * Simon Peyton-Jones, Stephanie Weirich, Richard Eisenberg,
-- Dimitrios Vytiniotis. "A reflection on types."
-- /Proc. Philip Wadler's 60th birthday Festschrift/, Edinburgh (April 2016).
--
-- The interface provides 'I.TypeRep', a type representation which can
-- be safely decomposed and composed. See "Data.Dynamic" for an example of this.
--
-- @since 4.10.0.0
--
-----------------------------------------------------------------------------
module Type.Reflection
    ( -- * The Typeable class
      I.Typeable
    , I.typeRep
    , I.withTypeable

      -- * Propositional equality
    , (:~:)(Refl)
    , (:~~:)(HRefl)

      -- * Type representations
      -- ** Type-Indexed
    , I.TypeRep
    , I.typeOf
    , pattern I.App, pattern I.Con, pattern I.Con', pattern I.Fun
    , I.typeRepTyCon
    , I.rnfTypeRep
    , I.eqTypeRep
    , I.typeRepKind
    , I.splitApps

      -- ** Quantified
      --
      -- "Data.Typeable" exports a variant of this interface (named differently
      -- for backwards compatibility).
    , I.SomeTypeRep(..)
    , I.someTypeRep
    , I.someTypeRepTyCon
    , I.rnfSomeTypeRep

      -- * Type constructors
    , I.TyCon           -- abstract, instance of: Eq, Show, Typeable
                        -- For now don't export Module, to avoid name clashes
    , I.tyConPackage
    , I.tyConModule
    , I.tyConName
    , I.rnfTyCon

      -- * Module names
    , I.Module
    , I.moduleName, I.modulePackage, I.rnfModule
    ) where

import qualified Data.Typeable.Internal as I
import Data.Type.Equality


-----------------------------------------------------------------------------
-- |
-- Module      :  Type.Reflection.Unsafe
-- Copyright   :  (c) The University of Glasgow, CWI 2001--2015
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- The representations of the types 'TyCon' and 'TypeRep', and the function
-- 'mkTyCon' which is used by derived instances of 'Typeable' to construct
-- 'TyCon's.
--
-- Be warned, these functions can be used to construct ill-kinded
-- type representations.
--
-----------------------------------------------------------------------------
{-# LANGUAGE PolyKinds, DataKinds, ScopedTypeVariables #-}

module Type.Reflection.Unsafe (
      -- * Type representations
      TypeRep, mkTrApp, mkTyCon, typeRepFingerprint, someTypeRepFingerprint
      -- * Kind representations
    , KindRep(..), TypeLitSort(..)
      -- * Type constructors
    , TyCon, mkTrCon, tyConKindRep, tyConKindArgs, tyConFingerprint
  ) where

import Data.Typeable.Internal hiding (mkTrApp)
import qualified Data.Typeable.Internal as TI

-- | Construct a representation for a type application.
mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
           TypeRep (a :: k1 -> k2)
        -> TypeRep (b :: k1)
        -> TypeRep (a b)
mkTrApp = TI.mkTrAppChecked


{-# LANGUAGE Unsafe #-}
{-# LANGUAGE NoImplicitPrelude, MagicHash #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Unsafe.Coerce
-- Copyright   :  Malcolm Wallace 2006
-- License     :  BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- The highly unsafe primitive 'unsafeCoerce' converts a value from any
-- type to any other type.  Needless to say, if you use this function,
-- it is your responsibility to ensure that the old and new types have
-- identical internal representations, in order to prevent runtime corruption.
--
-- The types for which 'unsafeCoerce' is representation-safe may differ
-- from compiler to compiler (and version to version).
--
--   * Documentation for correct usage in GHC will be found under
--     'unsafeCoerce#' in "GHC.Base" (around which 'unsafeCoerce' is just a
--     trivial wrapper).
--
--   * In nhc98, the only representation-safe coercions are between
--     'Prelude.Enum' types with the same range (e.g. 'Prelude.Int',
--     'Data.Int.Int32', 'Prelude.Char', 'Data.Word.Word32'), or between a
--     newtype and the type that it wraps.
--
-----------------------------------------------------------------------------

module Unsafe.Coerce (unsafeCoerce) where

import GHC.Integer () -- See Note [Depend on GHC.Integer] in GHC.Base
import GHC.Natural () -- See Note [Depend on GHC.Natural] in GHC.Base
import GHC.Prim (unsafeCoerce#)

local_id :: a -> a
local_id x = x   -- See Note [Mega-hack for coerce]

{- Note [Mega-hack for coerce]

If we just say
  unsafeCoerce x = unsafeCoerce# x
then the simple-optimiser that the desugarer runs will eta-reduce to
  unsafeCoerce :: forall (a:*) (b:*). a -> b
  unsafeCoerce = unsafeCoerce#
But we shouldn't be calling unsafeCoerce# in a higher
order way; it has a compulsory unfolding
   unsafeCoerce# a b x = x |> UnsafeCo a b
and we really rely on it being inlined pronto. But the simple-optimiser doesn't.
The identity function local_id delays the eta reduction just long enough
for unsafeCoerce# to get inlined.

Sigh. This is horrible, but then so is unsafeCoerce.
-}

unsafeCoerce :: a -> b
unsafeCoerce x = local_id (unsafeCoerce# x)
  -- See Note [Unsafe coerce magic] in basicTypes/MkId
  -- NB: Do not eta-reduce this definition (see above)


{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | See @GHC.LanguageExtensions@ for an explanation
-- on why this is needed
module GHC.ForeignSrcLang
  ( module GHC.ForeignSrcLang.Type
  ) where

import Data.Binary
import GHC.ForeignSrcLang.Type

instance Binary ForeignSrcLang


-- | See GHC #10762 and #15021.
module GHC.HandleEncoding (configureHandleEncoding) where

import Prelude -- See note [Why do we import Prelude here?]
import GHC.IO.Encoding (textEncodingName)
import System.Environment
import System.IO

-- | Handle GHC-specific character encoding flags, allowing us to control how
-- GHC produces output regardless of OS.
configureHandleEncoding :: IO ()
configureHandleEncoding = do
   env <- getEnvironment
   case lookup "GHC_CHARENC" env of
    Just "UTF-8" -> do
     hSetEncoding stdout utf8
     hSetEncoding stderr utf8
    _ -> do
     -- Avoid GHC erroring out when trying to display unhandled characters
     hSetTranslit stdout
     hSetTranslit stderr

-- | Change the character encoding of the given Handle to transliterate
-- on unsupported characters instead of throwing an exception
hSetTranslit :: Handle -> IO ()
hSetTranslit h = do
    menc <- hGetEncoding h
    case fmap textEncodingName menc of
        Just name | '/' `notElem` name -> do
            enc' <- mkTextEncoding $ name ++ "//TRANSLIT"
            hSetEncoding h enc'
        _ -> return ()


{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | This module re-exports the 'Extension' type along with an orphan 'Binary'
-- instance for it.
--
-- Note that the @ghc-boot@ package has a large set of dependencies; for this
-- reason the 'Extension' type itself is defined in the
-- "GHC.LanguageExtensions.Type" module provided by the @ghc-boot-th@ package,
-- which has no dependencies outside of @base@. For this reason
-- @template-haskell@ depends upon @ghc-boot-th@, not @ghc-boot@.
--
module GHC.LanguageExtensions ( module GHC.LanguageExtensions.Type ) where

import Data.Binary
import GHC.LanguageExtensions.Type

instance Binary Extension


{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.PackageDb
-- Copyright   :  (c) The University of Glasgow 2009, Duncan Coutts 2014
--
-- Maintainer  :  ghc-devs@haskell.org
-- Portability :  portable
--
-- This module provides the view of GHC's database of registered packages that
-- is shared between GHC the compiler\/library, and the ghc-pkg program. It
-- defines the database format that is shared between GHC and ghc-pkg.
--
-- The database format, and this library are constructed so that GHC does not
-- have to depend on the Cabal library. The ghc-pkg program acts as the
-- gateway between the external package format (which is defined by Cabal) and
-- the internal package format which is specialised just for GHC.
--
-- GHC the compiler only needs some of the information which is kept about
-- registerd packages, such as module names, various paths etc. On the other
-- hand ghc-pkg has to keep all the information from Cabal packages and be able
-- to regurgitate it for users and other tools.
--
-- The first trick is that we duplicate some of the information in the package
-- database. We essentially keep two versions of the datbase in one file, one
-- version used only by ghc-pkg which keeps the full information (using the
-- serialised form of the 'InstalledPackageInfo' type defined by the Cabal
-- library); and a second version written by ghc-pkg and read by GHC which has
-- just the subset of information that GHC needs.
--
-- The second trick is that this module only defines in detail the format of
-- the second version -- the bit GHC uses -- and the part managed by ghc-pkg
-- is kept in the file but here we treat it as an opaque blob of data. That way
-- this library avoids depending on Cabal.
--
module GHC.PackageDb (
       InstalledPackageInfo(..),
       DbModule(..),
       DbUnitId(..),
       BinaryStringRep(..),
       DbUnitIdModuleRep(..),
       emptyInstalledPackageInfo,
       PackageDbLock,
       lockPackageDb,
       unlockPackageDb,
       DbMode(..),
       DbOpenMode(..),
       isDbOpenReadMode,
       readPackageDbForGhc,
       readPackageDbForGhcPkg,
       writePackageDb
  ) where

import Prelude -- See note [Why do we import Prelude here?]
import Data.Version (Version(..))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS.Char8
import qualified Data.ByteString.Lazy as BS.Lazy
import qualified Data.ByteString.Lazy.Internal as BS.Lazy (defaultChunkSize)
import qualified Data.Foldable as F
import qualified Data.Traversable as F
import Data.Binary as Bin
import Data.Binary.Put as Bin
import Data.Binary.Get as Bin
import Control.Exception as Exception
import Control.Monad (when)
import System.FilePath
import System.IO
import System.IO.Error
import GHC.IO.Exception (IOErrorType(InappropriateType))
import GHC.IO.Handle.Lock
import System.Directory

-- | This is a subset of Cabal's 'InstalledPackageInfo', with just the bits
-- that GHC is interested in.  See Cabal's documentation for a more detailed
-- description of all of the fields.
--
data InstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulename mod
   = InstalledPackageInfo {
       unitId             :: instunitid,
       componentId        :: compid,
       instantiatedWith   :: [(modulename, mod)],
       sourcePackageId    :: srcpkgid,
       packageName        :: srcpkgname,
       packageVersion     :: Version,
       sourceLibName      :: Maybe srcpkgname,
       abiHash            :: String,
       depends            :: [instunitid],
       -- | Like 'depends', but each dependency is annotated with the
       -- ABI hash we expect the dependency to respect.
       abiDepends         :: [(instunitid, String)],
       importDirs         :: [FilePath],
       hsLibraries        :: [String],
       extraLibraries     :: [String],
       extraGHCiLibraries :: [String],
       libraryDirs        :: [FilePath],
       libraryDynDirs     :: [FilePath],
       frameworks         :: [String],
       frameworkDirs      :: [FilePath],
       ldOptions          :: [String],
       ccOptions          :: [String],
       includes           :: [String],
       includeDirs        :: [FilePath],
       haddockInterfaces  :: [FilePath],
       haddockHTMLs       :: [FilePath],
       exposedModules     :: [(modulename, Maybe mod)],
       hiddenModules      :: [modulename],
       indefinite         :: Bool,
       exposed            :: Bool,
       trusted            :: Bool
     }
  deriving (Eq, Show)

-- | A convenience constraint synonym for common constraints over parameters
-- to 'InstalledPackageInfo'.
type RepInstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulename mod =
    (BinaryStringRep srcpkgid, BinaryStringRep srcpkgname,
     BinaryStringRep modulename, BinaryStringRep compid,
     BinaryStringRep instunitid,
     DbUnitIdModuleRep instunitid compid unitid modulename mod)

-- | A type-class for the types which can be converted into 'DbModule'/'DbUnitId'.
-- There is only one type class because these types are mutually recursive.
-- NB: The functional dependency helps out type inference in cases
-- where types would be ambiguous.
class DbUnitIdModuleRep instunitid compid unitid modulename mod
    | mod -> unitid, unitid -> mod, mod -> modulename, unitid -> compid, unitid -> instunitid
    where
  fromDbModule :: DbModule instunitid compid unitid modulename mod -> mod
  toDbModule :: mod -> DbModule instunitid compid unitid modulename mod
  fromDbUnitId :: DbUnitId instunitid compid unitid modulename mod -> unitid
  toDbUnitId :: unitid -> DbUnitId instunitid compid unitid modulename mod

-- | @ghc-boot@'s copy of 'Module', i.e. what is serialized to the database.
-- Use 'DbUnitIdModuleRep' to convert it into an actual 'Module'.
-- It has phantom type parameters as this is the most convenient way
-- to avoid undecidable instances.
data DbModule instunitid compid unitid modulename mod
   = DbModule {
       dbModuleUnitId :: unitid,
       dbModuleName :: modulename
     }
   | DbModuleVar {
       dbModuleVarName :: modulename
     }
  deriving (Eq, Show)

-- | @ghc-boot@'s copy of 'UnitId', i.e. what is serialized to the database.
-- Use 'DbUnitIdModuleRep' to convert it into an actual 'UnitId'.
-- It has phantom type parameters as this is the most convenient way
-- to avoid undecidable instances.
data DbUnitId instunitid compid unitid modulename mod
   = DbUnitId compid [(modulename, mod)]
   | DbInstalledUnitId instunitid
  deriving (Eq, Show)

class BinaryStringRep a where
  fromStringRep :: BS.ByteString -> a
  toStringRep   :: a -> BS.ByteString

emptyInstalledPackageInfo :: RepInstalledPackageInfo a b c d e f g
                          => InstalledPackageInfo a b c d e f g
emptyInstalledPackageInfo =
  InstalledPackageInfo {
       unitId             = fromStringRep BS.empty,
       componentId        = fromStringRep BS.empty,
       instantiatedWith   = [],
       sourcePackageId    = fromStringRep BS.empty,
       packageName        = fromStringRep BS.empty,
       packageVersion     = Version [] [],
       sourceLibName      = Nothing,
       abiHash            = "",
       depends            = [],
       abiDepends         = [],
       importDirs         = [],
       hsLibraries        = [],
       extraLibraries     = [],
       extraGHCiLibraries = [],
       libraryDirs        = [],
       libraryDynDirs     = [],
       frameworks         = [],
       frameworkDirs      = [],
       ldOptions          = [],
       ccOptions          = [],
       includes           = [],
       includeDirs        = [],
       haddockInterfaces  = [],
       haddockHTMLs       = [],
       exposedModules     = [],
       hiddenModules      = [],
       indefinite         = False,
       exposed            = False,
       trusted            = False
  }

-- | Represents a lock of a package db.
newtype PackageDbLock = PackageDbLock Handle

-- | Acquire an exclusive lock related to package DB under given location.
lockPackageDb :: FilePath -> IO PackageDbLock

-- | Release the lock related to package DB.
unlockPackageDb :: PackageDbLock -> IO ()

-- | Acquire a lock of given type related to package DB under given location.
lockPackageDbWith :: LockMode -> FilePath -> IO PackageDbLock
lockPackageDbWith mode file = do
  -- We are trying to open the lock file and then lock it. Thus the lock file
  -- needs to either exist or we need to be able to create it. Ideally we
  -- would not assume that the lock file always exists in advance. When we are
  -- dealing with a package DB where we have write access then if the lock
  -- file does not exist then we can create it by opening the file in
  -- read/write mode. On the other hand if we are dealing with a package DB
  -- where we do not have write access (e.g. a global DB) then we can only
  -- open in read mode, and the lock file had better exist already or we're in
  -- trouble. So for global read-only DBs on platforms where we must lock the
  -- DB for reading then we will require that the installer/packaging has
  -- included the lock file.
  --
  -- Thus the logic here is to first try opening in read-write mode
  -- and if that fails we try read-only (to handle global read-only DBs).
  -- If either succeed then lock the file. IO exceptions (other than the first
  -- open attempt failing due to the file not existing) simply propagate.
  --
  -- Note that there is a complexity here which was discovered in #13945: some
  -- filesystems (e.g. NFS) will only allow exclusive locking if the fd was
  -- opened for write access. We would previously try opening the lockfile for
  -- read-only access first, however this failed when run on such filesystems.
  -- Consequently, we now try read-write access first, falling back to read-only
  -- if we are denied permission (e.g. in the case of a global database).
  catchJust
    (\e -> if isPermissionError e then Just () else Nothing)
    (lockFileOpenIn ReadWriteMode)
    (const $ lockFileOpenIn ReadMode)
  where
    lock = file <.> "lock"

    lockFileOpenIn io_mode = bracketOnError
      (openBinaryFile lock io_mode)
      hClose
      -- If file locking support is not available, ignore the error and proceed
      -- normally. Without it the only thing we lose on non-Windows platforms is
      -- the ability to safely issue concurrent updates to the same package db.
      $ \hnd -> do hLock hnd mode `catch` \FileLockingNotSupported -> return ()
                   return $ PackageDbLock hnd

lockPackageDb = lockPackageDbWith ExclusiveLock
unlockPackageDb (PackageDbLock hnd) = do
    hUnlock hnd
    hClose hnd

-- | Mode to open a package db in.
data DbMode = DbReadOnly | DbReadWrite

-- | 'DbOpenMode' holds a value of type @t@ but only in 'DbReadWrite' mode.  So
-- it is like 'Maybe' but with a type argument for the mode to enforce that the
-- mode is used consistently.
data DbOpenMode (mode :: DbMode) t where
  DbOpenReadOnly  ::      DbOpenMode 'DbReadOnly t
  DbOpenReadWrite :: t -> DbOpenMode 'DbReadWrite t

deriving instance Functor (DbOpenMode mode)
deriving instance F.Foldable (DbOpenMode mode)
deriving instance F.Traversable (DbOpenMode mode)

isDbOpenReadMode :: DbOpenMode mode t -> Bool
isDbOpenReadMode = \case
  DbOpenReadOnly    -> True
  DbOpenReadWrite{} -> False

-- | Read the part of the package DB that GHC is interested in.
--
readPackageDbForGhc :: RepInstalledPackageInfo a b c d e f g =>
                       FilePath -> IO [InstalledPackageInfo a b c d e f g]
readPackageDbForGhc file =
  decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case
    (pkgs, DbOpenReadOnly) -> return pkgs
  where
    getDbForGhc = do
      _version    <- getHeader
      _ghcPartLen <- get :: Get Word32
      ghcPart     <- get
      -- the next part is for ghc-pkg, but we stop here.
      return ghcPart

-- | Read the part of the package DB that ghc-pkg is interested in
--
-- Note that the Binary instance for ghc-pkg's representation of packages
-- is not defined in this package. This is because ghc-pkg uses Cabal types
-- (and Binary instances for these) which this package does not depend on.
--
-- If we open the package db in read only mode, we get its contents. Otherwise
-- we additionally receive a PackageDbLock that represents a lock on the
-- database, so that we can safely update it later.
--
readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t ->
                          IO (pkgs, DbOpenMode mode PackageDbLock)
readPackageDbForGhcPkg file mode =
    decodeFromFile file mode getDbForGhcPkg
  where
    getDbForGhcPkg = do
      _version    <- getHeader
      -- skip over the ghc part
      ghcPartLen  <- get :: Get Word32
      _ghcPart    <- skip (fromIntegral ghcPartLen)
      -- the next part is for ghc-pkg
      ghcPkgPart  <- get
      return ghcPkgPart

-- | Write the whole of the package DB, both parts.
--
writePackageDb :: (Binary pkgs, RepInstalledPackageInfo a b c d e f g) =>
                  FilePath -> [InstalledPackageInfo a b c d e f g] ->
                  pkgs -> IO ()
writePackageDb file ghcPkgs ghcPkgPart =
  writeFileAtomic file (runPut putDbForGhcPkg)
  where
    putDbForGhcPkg = do
        putHeader
        put               ghcPartLen
        putLazyByteString ghcPart
        put               ghcPkgPart
      where
        ghcPartLen :: Word32
        ghcPartLen = fromIntegral (BS.Lazy.length ghcPart)
        ghcPart    = encode ghcPkgs

getHeader :: Get (Word32, Word32)
getHeader = do
    magic <- getByteString (BS.length headerMagic)
    when (magic /= headerMagic) $
      fail "not a ghc-pkg db file, wrong file magic number"

    majorVersion <- get :: Get Word32
    -- The major version is for incompatible changes

    minorVersion <- get :: Get Word32
    -- The minor version is for compatible extensions

    when (majorVersion /= 1) $
      fail "unsupported ghc-pkg db format version"
    -- If we ever support multiple major versions then we'll have to change
    -- this code

    -- The header can be extended without incrementing the major version,
    -- we ignore fields we don't know about (currently all).
    headerExtraLen <- get :: Get Word32
    skip (fromIntegral headerExtraLen)

    return (majorVersion, minorVersion)

putHeader :: Put
putHeader = do
    putByteString headerMagic
    put majorVersion
    put minorVersion
    put headerExtraLen
  where
    majorVersion   = 1 :: Word32
    minorVersion   = 0 :: Word32
    headerExtraLen = 0 :: Word32

headerMagic :: BS.ByteString
headerMagic = BS.Char8.pack "\0ghcpkg\0"

-- TODO: we may be able to replace the following with utils from the binary
-- package in future.

-- | Feed a 'Get' decoder with data chunks from a file.
--
decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs ->
                  IO (pkgs, DbOpenMode mode PackageDbLock)
decodeFromFile file mode decoder = case mode of
  DbOpenReadOnly -> do
  -- When we open the package db in read only mode, there is no need to acquire
  -- shared lock on non-Windows platform because we update the database with an
  -- atomic rename, so readers will always see the database in a consistent
  -- state.
#if defined(mingw32_HOST_OS)
    bracket (lockPackageDbWith SharedLock file) unlockPackageDb $ \_ -> do
#endif
      (, DbOpenReadOnly) <$> decodeFileContents
  DbOpenReadWrite{} -> do
    -- When we open the package db in read/write mode, acquire an exclusive lock
    -- on the database and return it so we can keep it for the duration of the
    -- update.
    bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do
      (, DbOpenReadWrite lock) <$> decodeFileContents
  where
    decodeFileContents = withBinaryFile file ReadMode $ \hnd ->
      feed hnd (runGetIncremental decoder)

    feed hnd (Partial k)  = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize
                               if BS.null chunk
                                 then feed hnd (k Nothing)
                                 else feed hnd (k (Just chunk))
    feed _ (Done _ _ res) = return res
    feed _ (Fail _ _ msg) = ioError err
      where
        err = mkIOError InappropriateType loc Nothing (Just file)
              `ioeSetErrorString` msg
        loc = "GHC.PackageDb.readPackageDb"

-- Copied from Cabal's Distribution.Simple.Utils.
writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO ()
writeFileAtomic targetPath content = do
  let (targetDir, targetFile) = splitFileName targetPath
  Exception.bracketOnError
    (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")
    (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
    (\(tmpPath, handle) -> do
        BS.Lazy.hPut handle content
        hClose handle
        renameFile tmpPath targetPath)

instance (RepInstalledPackageInfo a b c d e f g) =>
         Binary (InstalledPackageInfo a b c d e f g) where
  put (InstalledPackageInfo
         unitId componentId instantiatedWith sourcePackageId
         packageName packageVersion
         sourceLibName
         abiHash depends abiDepends importDirs
         hsLibraries extraLibraries extraGHCiLibraries
         libraryDirs libraryDynDirs
         frameworks frameworkDirs
         ldOptions ccOptions
         includes includeDirs
         haddockInterfaces haddockHTMLs
         exposedModules hiddenModules
         indefinite exposed trusted) = do
    put (toStringRep sourcePackageId)
    put (toStringRep packageName)
    put packageVersion
    put (fmap toStringRep sourceLibName)
    put (toStringRep unitId)
    put (toStringRep componentId)
    put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod))
             instantiatedWith)
    put abiHash
    put (map toStringRep depends)
    put (map (\(k,v) -> (toStringRep k, v)) abiDepends)
    put importDirs
    put hsLibraries
    put extraLibraries
    put extraGHCiLibraries
    put libraryDirs
    put libraryDynDirs
    put frameworks
    put frameworkDirs
    put ldOptions
    put ccOptions
    put includes
    put includeDirs
    put haddockInterfaces
    put haddockHTMLs
    put (map (\(mod_name, mb_mod) -> (toStringRep mod_name, fmap toDbModule mb_mod))
             exposedModules)
    put (map toStringRep hiddenModules)
    put indefinite
    put exposed
    put trusted

  get = do
    sourcePackageId    <- get
    packageName        <- get
    packageVersion     <- get
    sourceLibName      <- get
    unitId             <- get
    componentId        <- get
    instantiatedWith   <- get
    abiHash            <- get
    depends            <- get
    abiDepends         <- get
    importDirs         <- get
    hsLibraries        <- get
    extraLibraries     <- get
    extraGHCiLibraries <- get
    libraryDirs        <- get
    libraryDynDirs     <- get
    frameworks         <- get
    frameworkDirs      <- get
    ldOptions          <- get
    ccOptions          <- get
    includes           <- get
    includeDirs        <- get
    haddockInterfaces  <- get
    haddockHTMLs       <- get
    exposedModules     <- get
    hiddenModules      <- get
    indefinite         <- get
    exposed            <- get
    trusted            <- get
    return (InstalledPackageInfo
              (fromStringRep unitId)
              (fromStringRep componentId)
              (map (\(mod_name, mod) -> (fromStringRep mod_name, fromDbModule mod))
                instantiatedWith)
              (fromStringRep sourcePackageId)
              (fromStringRep packageName) packageVersion
              (fmap fromStringRep sourceLibName)
              abiHash
              (map fromStringRep depends)
              (map (\(k,v) -> (fromStringRep k, v)) abiDepends)
              importDirs
              hsLibraries extraLibraries extraGHCiLibraries
              libraryDirs libraryDynDirs
              frameworks frameworkDirs
              ldOptions ccOptions
              includes includeDirs
              haddockInterfaces haddockHTMLs
              (map (\(mod_name, mb_mod) ->
                        (fromStringRep mod_name, fmap fromDbModule mb_mod))
                   exposedModules)
              (map fromStringRep hiddenModules)
              indefinite exposed trusted)

instance (BinaryStringRep modulename, BinaryStringRep compid,
          BinaryStringRep instunitid,
          DbUnitIdModuleRep instunitid compid unitid modulename mod) =>
         Binary (DbModule instunitid compid unitid modulename mod) where
  put (DbModule dbModuleUnitId dbModuleName) = do
    putWord8 0
    put (toDbUnitId dbModuleUnitId)
    put (toStringRep dbModuleName)
  put (DbModuleVar dbModuleVarName) = do
    putWord8 1
    put (toStringRep dbModuleVarName)
  get = do
    b <- getWord8
    case b of
      0 -> do dbModuleUnitId <- get
              dbModuleName <- get
              return (DbModule (fromDbUnitId dbModuleUnitId)
                               (fromStringRep dbModuleName))
      _ -> do dbModuleVarName <- get
              return (DbModuleVar (fromStringRep dbModuleVarName))

instance (BinaryStringRep modulename, BinaryStringRep compid,
          BinaryStringRep instunitid,
          DbUnitIdModuleRep instunitid compid unitid modulename mod) =>
         Binary (DbUnitId instunitid compid unitid modulename mod) where
  put (DbInstalledUnitId instunitid) = do
    putWord8 0
    put (toStringRep instunitid)
  put (DbUnitId dbUnitIdComponentId dbUnitIdInsts) = do
    putWord8 1
    put (toStringRep dbUnitIdComponentId)
    put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod)) dbUnitIdInsts)
  get = do
    b <- getWord8
    case b of
      0 -> do
        instunitid <- get
        return (DbInstalledUnitId (fromStringRep instunitid))
      _ -> do
        dbUnitIdComponentId <- get
        dbUnitIdInsts <- get
        return (DbUnitId
            (fromStringRep dbUnitIdComponentId)
            (map (\(mod_name, mod) -> ( fromStringRep mod_name
                                      , fromDbModule mod))
                 dbUnitIdInsts))


{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

--
-- (c) The University of Glasgow 2002-2006
--
-- Serialized values

module GHC.Serialized (
    -- * Main Serialized data type
    Serialized(..),

    -- * Going into and out of 'Serialized'
    toSerialized, fromSerialized,

    -- * Handy serialization functions
    serializeWithData, deserializeWithData,
  ) where

import Prelude -- See note [Why do we import Prelude here?]
import Data.Bits
import Data.Word        ( Word8 )
import Data.Data

-- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types
data Serialized = Serialized TypeRep [Word8]

-- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later
toSerialized :: forall a. Typeable a => (a -> [Word8]) -> a -> Serialized
toSerialized serialize what = Serialized (typeOf what) (serialize what)

-- | If the 'Serialized' value contains something of the given type, then use the specified deserializer to return @Just@ that.
-- Otherwise return @Nothing@.
fromSerialized :: forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a
fromSerialized deserialize (Serialized the_type bytes)
  | the_type == rep = Just (deserialize bytes)
  | otherwise       = Nothing
  where rep = typeRep (Proxy :: Proxy a)

-- | Use a 'Data' instance to implement a serialization scheme dual to that of 'deserializeWithData'
serializeWithData :: Data a => a -> [Word8]
serializeWithData what = serializeWithData' what []

serializeWithData' :: Data a => a -> [Word8] -> [Word8]
serializeWithData' what = fst $ gfoldl (\(before, a_to_b) a -> (before . serializeWithData' a, a_to_b a))
                                       (\x -> (serializeConstr (constrRep (toConstr what)), x))
                                       what

-- | Use a 'Data' instance to implement a deserialization scheme dual to that of 'serializeWithData'
deserializeWithData :: Data a => [Word8] -> a
deserializeWithData = snd . deserializeWithData'

deserializeWithData' :: forall a. Data a => [Word8] -> ([Word8], a)
deserializeWithData' bytes = deserializeConstr bytes $ \constr_rep bytes ->
                             gunfold (\(bytes, b_to_r) -> let (bytes', b) = deserializeWithData' bytes in (bytes', b_to_r b))
                                     (\x -> (bytes, x))
                                     (repConstr (dataTypeOf (undefined :: a)) constr_rep)

serializeConstr :: ConstrRep -> [Word8] -> [Word8]
serializeConstr (AlgConstr ix)   = serializeWord8 1 . serializeInt ix
serializeConstr (IntConstr i)    = serializeWord8 2 . serializeInteger i
serializeConstr (FloatConstr r)  = serializeWord8 3 . serializeRational r
serializeConstr (CharConstr c)   = serializeWord8 4 . serializeChar c

deserializeConstr :: [Word8] -> (ConstrRep -> [Word8] -> a) -> a
deserializeConstr bytes k = deserializeWord8 bytes $ \constr_ix bytes ->
                            case constr_ix of
                                1 -> deserializeInt      bytes $ \ix -> k (AlgConstr ix)
                                2 -> deserializeInteger  bytes $ \i  -> k (IntConstr i)
                                3 -> deserializeRational bytes $ \r  -> k (FloatConstr r)
                                4 -> deserializeChar     bytes $ \c  -> k (CharConstr c)
                                x -> error $ "deserializeConstr: unrecognised serialized constructor type " ++ show x ++ " in context " ++ show bytes

serializeFixedWidthNum :: forall a. (Integral a, FiniteBits a) => a -> [Word8] -> [Word8]
serializeFixedWidthNum what = go (finiteBitSize what) what
  where
    go :: Int -> a -> [Word8] -> [Word8]
    go size current rest
      | size <= 0 = rest
      | otherwise = fromIntegral (current .&. 255) : go (size - 8) (current `shiftR` 8) rest

deserializeFixedWidthNum :: forall a b. (Integral a, FiniteBits a) => [Word8] -> (a -> [Word8] -> b) -> b
deserializeFixedWidthNum bytes k = go (finiteBitSize (undefined :: a)) bytes k
  where
    go :: Int -> [Word8] -> (a -> [Word8] -> b) -> b
    go size bytes k
      | size <= 0 = k 0 bytes
      | otherwise = case bytes of
                        (byte:bytes) -> go (size - 8) bytes (\x -> k ((x `shiftL` 8) .|. fromIntegral byte))
                        []           -> error "deserializeFixedWidthNum: unexpected end of stream"

serializeEnum :: (Enum a) => a -> [Word8] -> [Word8]
serializeEnum = serializeInt . fromEnum

deserializeEnum :: Enum a => [Word8] -> (a -> [Word8] -> b) -> b
deserializeEnum bytes k = deserializeInt bytes (k . toEnum)

serializeWord8 :: Word8 -> [Word8] -> [Word8]
serializeWord8 x = (x:)

deserializeWord8 :: [Word8] -> (Word8 -> [Word8] -> a) -> a
deserializeWord8 (byte:bytes) k = k byte bytes
deserializeWord8 []           _ = error "deserializeWord8: unexpected end of stream"

serializeInt :: Int -> [Word8] -> [Word8]
serializeInt = serializeFixedWidthNum

deserializeInt :: [Word8] -> (Int -> [Word8] -> a) -> a
deserializeInt = deserializeFixedWidthNum

serializeRational :: (Real a) => a -> [Word8] -> [Word8]
serializeRational = serializeString . show . toRational

deserializeRational :: (Fractional a) => [Word8] -> (a -> [Word8] -> b) -> b
deserializeRational bytes k = deserializeString bytes (k . fromRational . read)

serializeInteger :: Integer -> [Word8] -> [Word8]
serializeInteger = serializeString . show

deserializeInteger :: [Word8] -> (Integer -> [Word8] -> a) -> a
deserializeInteger bytes k = deserializeString bytes (k . read)

serializeChar :: Char -> [Word8] -> [Word8]
serializeChar = serializeString . show

deserializeChar :: [Word8] -> (Char -> [Word8] -> a) -> a
deserializeChar bytes k = deserializeString bytes (k . read)

serializeString :: String -> [Word8] -> [Word8]
serializeString = serializeList serializeEnum

deserializeString :: [Word8] -> (String -> [Word8] -> a) -> a
deserializeString = deserializeList deserializeEnum

serializeList :: (a -> [Word8] -> [Word8]) -> [a] -> [Word8] -> [Word8]
serializeList serialize_element xs = serializeInt (length xs) . foldr (.) id (map serialize_element xs)

deserializeList :: forall a b. (forall c. [Word8] -> (a -> [Word8] -> c) -> c)
                -> [Word8] -> ([a] -> [Word8] -> b) -> b
deserializeList deserialize_element bytes k = deserializeInt bytes $ \len bytes -> go len bytes k
  where
    go :: Int -> [Word8] -> ([a] -> [Word8] -> b) -> b
    go len bytes k
      | len <= 0  = k [] bytes
      | otherwise = deserialize_element bytes (\elt bytes -> go (len - 1) bytes (k . (elt:)))


-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Lexeme
-- Copyright   :  (c) The GHC Team
--
-- Maintainer  :  ghc-devs@haskell.org
-- Portability :  portable
--
-- Functions to evaluate whether or not a string is a valid identifier.
--
module GHC.Lexeme (
          -- * Lexical characteristics of Haskell names
        startsVarSym, startsVarId, startsConSym, startsConId,
        startsVarSymASCII, isVarSymChar, okSymChar
  ) where

import Prelude -- See note [Why do we import Prelude here?]
import Data.Char

-- | Is this character acceptable in a symbol (after the first char)?
-- See alexGetByte in Lexer.x
okSymChar :: Char -> Bool
okSymChar c
  | c `elem` "(),;[]`{}_\"'"
  = False
  | otherwise
  = case generalCategory c of
      ConnectorPunctuation -> True
      DashPunctuation      -> True
      OtherPunctuation     -> True
      MathSymbol           -> True
      CurrencySymbol       -> True
      ModifierSymbol       -> True
      OtherSymbol          -> True
      _                    -> False

startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool
startsVarSym c = okSymChar cÂ && c /= ':' -- Infix Ids
startsConSym c = c == ':'                -- Infix data constructors
startsVarId c  = c == '_' || case generalCategory c of  -- Ordinary Ids
  LowercaseLetter -> True
  OtherLetter     -> True   -- See #1103
  _               -> False
startsConId c  = isUpper c || c == '('  -- Ordinary type constructors and data constructors

startsVarSymASCII :: Char -> Bool
startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"

isVarSymChar :: Char -> Bool
isVarSymChar c = c == ':' || startsVarSym c


{-# LANGUAGE DeriveGeneric #-}
module GHC.ForeignSrcLang.Type
  ( ForeignSrcLang(..)
  ) where

import Prelude -- See note [Why do we import Prelude here?]
import GHC.Generics (Generic)

-- | Foreign formats supported by GHC via TH
data ForeignSrcLang
  = LangC      -- ^ C
  | LangCxx    -- ^ C++
  | LangObjc   -- ^ Objective C
  | LangObjcxx -- ^ Objective C++
  | LangAsm    -- ^ Assembly language (.s)
  | RawObject  -- ^ Object (.o)
  deriving (Eq, Show, Generic)


-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.LanguageExtensions.Type
-- Copyright   :  (c) The GHC Team
--
-- Maintainer  :  ghc-devs@haskell.org
-- Portability :  portable
--
-- A data type defining the language extensions supported by GHC.
--
{-# LANGUAGE DeriveGeneric #-}
module GHC.LanguageExtensions.Type ( Extension(..) ) where

import Prelude -- See note [Why do we import Prelude here?]
import GHC.Generics

-- | The language extensions known to GHC.
--
-- Note that there is an orphan 'Binary' instance for this type supplied by
-- the "GHC.LanguageExtensions" module provided by @ghc-boot@. We can't provide
-- here as this would require adding transitive dependencies to the
-- @template-haskell@ package, which must have a minimal dependency set.
data Extension
-- See Note [Updating flag description in the User's Guide] in DynFlags
   = Cpp
   | OverlappingInstances
   | UndecidableInstances
   | IncoherentInstances
   | UndecidableSuperClasses
   | MonomorphismRestriction
   | MonoPatBinds
   | MonoLocalBinds
   | RelaxedPolyRec           -- Deprecated
   | ExtendedDefaultRules     -- Use GHC's extended rules for defaulting
   | ForeignFunctionInterface
   | UnliftedFFITypes
   | InterruptibleFFI
   | CApiFFI
   | GHCForeignImportPrim
   | JavaScriptFFI
   | ParallelArrays           -- Syntactic support for parallel arrays
   | Arrows                   -- Arrow-notation syntax
   | TemplateHaskell
   | TemplateHaskellQuotes    -- subset of TH supported by stage1, no splice
   | QuasiQuotes
   | ImplicitParams
   | ImplicitPrelude
   | ScopedTypeVariables
   | AllowAmbiguousTypes
   | UnboxedTuples
   | UnboxedSums
   | BangPatterns
   | TypeFamilies
   | TypeFamilyDependencies
   | TypeInType
   | OverloadedStrings
   | OverloadedLists
   | NumDecimals
   | DisambiguateRecordFields
   | RecordWildCards
   | RecordPuns
   | ViewPatterns
   | GADTs
   | GADTSyntax
   | NPlusKPatterns
   | DoAndIfThenElse
   | BlockArguments
   | RebindableSyntax
   | ConstraintKinds
   | PolyKinds                -- Kind polymorphism
   | DataKinds                -- Datatype promotion
   | InstanceSigs
   | ApplicativeDo

   | StandaloneDeriving
   | DeriveDataTypeable
   | AutoDeriveTypeable       -- Automatic derivation of Typeable
   | DeriveFunctor
   | DeriveTraversable
   | DeriveFoldable
   | DeriveGeneric            -- Allow deriving Generic/1
   | DefaultSignatures        -- Allow extra signatures for defmeths
   | DeriveAnyClass           -- Allow deriving any class
   | DeriveLift               -- Allow deriving Lift
   | DerivingStrategies
   | DerivingVia              -- Derive through equal representation

   | TypeSynonymInstances
   | FlexibleContexts
   | FlexibleInstances
   | ConstrainedClassMethods
   | MultiParamTypeClasses
   | NullaryTypeClasses
   | FunctionalDependencies
   | UnicodeSyntax
   | ExistentialQuantification
   | MagicHash
   | EmptyDataDecls
   | KindSignatures
   | RoleAnnotations
   | ParallelListComp
   | TransformListComp
   | MonadComprehensions
   | GeneralizedNewtypeDeriving
   | RecursiveDo
   | PostfixOperators
   | TupleSections
   | PatternGuards
   | LiberalTypeSynonyms
   | RankNTypes
   | ImpredicativeTypes
   | TypeOperators
   | ExplicitNamespaces
   | PackageImports
   | ExplicitForAll
   | AlternativeLayoutRule
   | AlternativeLayoutRuleTransitional
   | DatatypeContexts
   | NondecreasingIndentation
   | RelaxedLayout
   | TraditionalRecordSyntax
   | LambdaCase
   | MultiWayIf
   | BinaryLiterals
   | NegativeLiterals
   | HexFloatLiterals
   | DuplicateRecordFields
   | OverloadedLabels
   | EmptyCase
   | PatternSynonyms
   | PartialTypeSignatures
   | NamedWildCards
   | StaticPointers
   | TypeApplications
   | Strict
   | StrictData
   | MonadFailDesugaring
   | EmptyDataDeriving
   | NumericUnderscores
   | QuantifiedConstraints
   | StarIsType
   deriving (Eq, Enum, Show, Generic)


module Main (main) where

import Distribution.Simple

main :: IO ()
main = defaultMain


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-name-shadowing #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Compact
-- Copyright   :  (c) The University of Glasgow 2001-2009
--                (c) Giovanni Campagna <gcampagn@cs.stanford.edu> 2014
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  unstable
-- Portability :  non-portable (GHC Extensions)
--
-- This module provides a data structure, called a 'Compact', for
-- holding immutable, fully evaluated data in a consecutive block of memory.
-- Compact regions are good for two things:
--
--  1. Data in a compact region is not traversed during GC; any
--  incoming pointer to a compact region keeps the entire region
--  live.  Thus, if you put a long-lived data structure in a compact
--  region, you may save a lot of cycles during major collections,
--  since you will no longer be (uselessly) retraversing this
--  data structure.
--
--  2. Because the data is stored contiguously, you can easily
--  dump the memory to disk and/or send it over the network.
--  For applications that are not bandwidth bound (GHC's heap
--  representation can be as much of a x4 expansion over a
--  binary serialization), this can lead to substantial speedups.
--
-- For example, suppose you have a function @loadBigStruct :: IO BigStruct@,
-- which loads a large data structure from the file system.  You can "compact"
-- the structure with the following code:
--
-- @
--      do r <- 'compact' =<< loadBigStruct
--         let x = 'getCompact' r :: BigStruct
--         -- Do things with x
-- @
--
-- Note that 'compact' will not preserve internal sharing; use
-- 'compactWithSharing' (which is 10x slower) if you have cycles and/or
-- must preserve sharing.  The 'Compact' pointer @r@ can be used
-- to add more data to a compact region; see 'compactAdd' or
-- 'compactAddWithSharing'.
--
-- The implementation of compact regions is described by:
--
--  * Edward Z. Yang, Giovanni Campagna, Ã–mer AÄŸacan, Ahmed El-Hassany, Abhishek
--    Kulkarni, Ryan Newton. \"/Efficient communication and Collection with Compact
--    Normal Forms/\". In Proceedings of the 20th ACM SIGPLAN International
--    Conference on Functional Programming. September 2015. <http://ezyang.com/compact.html>
--
-- This library is supported by GHC 8.2 and later.

module GHC.Compact (
  -- * The Compact type
  Compact(..),

  -- * Compacting data
  compact,
  compactWithSharing,
  compactAdd,
  compactAddWithSharing,

  -- * Inspecting a Compact
  getCompact,
  inCompact,
  isCompact,
  compactSize,

  -- * Other utilities
  compactResize,

  -- * Internal operations
  mkCompact,
  compactSized,
  ) where

import Control.Concurrent.MVar
import GHC.Prim
import GHC.Types

-- | A 'Compact' contains fully evaluated, pure, immutable data.
--
-- 'Compact' serves two purposes:
--
-- * Data stored in a 'Compact' has no garbage collection overhead.
--   The garbage collector considers the whole 'Compact' to be alive
--   if there is a reference to any object within it.
--
-- * A 'Compact' can be serialized, stored, and deserialized again.
--   The serialized data can only be deserialized by the exact binary
--   that created it, but it can be stored indefinitely before
--   deserialization.
--
-- Compacts are self-contained, so compacting data involves copying
-- it; if you have data that lives in two 'Compact's, each will have a
-- separate copy of the data.
--
-- The cost of compaction is similar to the cost of GC for the same
-- data, but it is performed only once.  However, because
-- "GHC.Compact.compact" does not stop-the-world, retaining internal
-- sharing during the compaction process is very costly. The user
-- can choose whether to 'compact' or 'compactWithSharing'.
--
-- When you have a @'Compact' a@, you can get a pointer to the actual object
-- in the region using "GHC.Compact.getCompact".  The 'Compact' type
-- serves as handle on the region itself; you can use this handle
-- to add data to a specific 'Compact' with 'compactAdd' or
-- 'compactAddWithSharing' (giving you a new handle which corresponds
-- to the same compact region, but points to the newly added object
-- in the region).  At the moment, due to technical reasons,
-- it's not possible to get the @'Compact' a@ if you only have an @a@,
-- so make sure you hold on to the handle as necessary.
--
-- Data in a compact doesn't ever move, so compacting data is also a
-- way to pin arbitrary data structures in memory.
--
-- There are some limitations on what can be compacted:
--
-- * Functions.  Compaction only applies to data.
--
-- * Pinned 'ByteArray#' objects cannot be compacted.  This is for a
--   good reason: the memory is pinned so that it can be referenced by
--   address (the address might be stored in a C data structure, for
--   example), so we can't make a copy of it to store in the 'Compact'.
--
-- * Objects with mutable pointer fields (e.g. 'Data.IORef.IORef',
--   'GHC.Array.MutableArray') also cannot be compacted, because subsequent
--   mutation would destroy the property that a compact is self-contained.
--
-- If compaction encounters any of the above, a 'CompactionFailed'
-- exception will be thrown by the compaction operation.
--
data Compact a = Compact Compact# a (MVar ())
    -- we can *read* from a Compact without taking a lock, but only
    -- one thread can be writing to the compact at any given time.
    -- The MVar here is to enforce mutual exclusion among writers.
    -- Note: the MVar protects the Compact# only, not the pure value 'a'

-- | Make a new 'Compact' object, given a pointer to the true
-- underlying region.  You must uphold the invariant that @a@ lives
-- in the compact region.
--
mkCompact
  :: Compact# -> a -> State# RealWorld -> (# State# RealWorld, Compact a #)
mkCompact compact# a s =
  case unIO (newMVar ()) s of { (# s1, lock #) ->
  (# s1, Compact compact# a lock #) }
 where
  unIO (IO a) = a

-- | Transfer @a@ into a new compact region, with a preallocated size,
-- possibly preserving sharing or not.  If you know how big the data
-- structure in question is, you can save time by picking an appropriate
-- block size for the compact region.
--
compactSized :: Int -> Bool -> a -> IO (Compact a)
compactSized (I# size) share a = IO $ \s0 ->
  case compactNew# (int2Word# size) s0 of { (# s1, compact# #) ->
  case compactAddPrim compact# a s1 of { (# s2, pk #) ->
  mkCompact compact# pk s2 }}
 where
  compactAddPrim
    | share = compactAddWithSharing#
    | otherwise = compactAdd#

-- | Retrieve a direct pointer to the value pointed at by a 'Compact' reference.
-- If you have used 'compactAdd', there may be multiple 'Compact' references
-- into the same compact region. Upholds the property:
--
-- > inCompact c (getCompact c) == True
--
getCompact :: Compact a -> a
getCompact (Compact _ obj _) = obj

-- | Compact a value. /O(size of unshared data)/
--
-- If the structure contains any internal sharing, the shared data
-- will be duplicated during the compaction process.  This will
-- not terminate if the structure contains cycles (use 'compactWithSharing'
-- instead).
--
-- The object in question must not contain any functions or data with mutable
-- pointers; if it does, 'compact' will raise an exception. In the future, we
-- may add a type class which will help statically check if this is the case or
-- not.
--
compact :: a -> IO (Compact a)
compact = compactSized 31268 False

-- | Compact a value, retaining any internal sharing and
-- cycles. /O(size of data)/
--
-- This is typically about 10x slower than 'compact', because it works
-- by maintaining a hash table mapping uncompacted objects to
-- compacted objects.
--
-- The object in question must not contain any functions or data with mutable
-- pointers; if it does, 'compact' will raise an exception. In the future, we
-- may add a type class which will help statically check if this is the case or
-- not.
--
compactWithSharing :: a -> IO (Compact a)
compactWithSharing = compactSized 31268 True

-- | Add a value to an existing 'Compact'.  This will help you avoid
-- copying when the value contains pointers into the compact region,
-- but remember that after compaction this value will only be deallocated
-- with the entire compact region.
--
-- Behaves exactly like 'compact' with respect to sharing and what data
-- it accepts.
--
compactAdd :: Compact b -> a -> IO (Compact a)
compactAdd (Compact compact# _ lock) a = withMVar lock $ \_ -> IO $ \s ->
  case compactAdd# compact# a s of { (# s1, pk #) ->
  (# s1, Compact compact# pk lock #) }

-- | Add a value to an existing 'Compact', like 'compactAdd',
-- but behaving exactly like 'compactWithSharing' with respect to sharing and
-- what data it accepts.
--
compactAddWithSharing :: Compact b -> a -> IO (Compact a)
compactAddWithSharing (Compact compact# _ lock) a =
  withMVar lock $ \_ -> IO $ \s ->
    case compactAddWithSharing# compact# a s of { (# s1, pk #) ->
    (# s1, Compact compact# pk lock #) }

-- | Check if the second argument is inside the passed 'Compact'.
--
inCompact :: Compact b -> a -> IO Bool
inCompact (Compact buffer _ _) !val =
  IO (\s -> case compactContains# buffer val s of
         (# s', v #) -> (# s', isTrue# v #) )

-- | Check if the argument is in any 'Compact'.  If true, the value in question
-- is also fully evaluated, since any value in a compact region must
-- be fully evaluated.
--
isCompact :: a -> IO Bool
isCompact !val =
  IO (\s -> case compactContainsAny# val s of
         (# s', v #) -> (# s', isTrue# v #) )

-- | Returns the size in bytes of the compact region.
--
compactSize :: Compact a -> IO Word
compactSize (Compact buffer _ lock) = withMVar lock $ \_ -> IO $ \s0 ->
   case compactSize# buffer s0 of (# s1, sz #) -> (# s1, W# sz #)

-- | *Experimental.*  This function doesn't actually resize a compact
-- region; rather, it changes the default block size which we allocate
-- when the current block runs out of space, and also appends a block
-- to the compact region.
--
compactResize :: Compact a -> Word -> IO ()
compactResize (Compact oldBuffer _ lock) (W# new_size) =
  withMVar lock $ \_ -> IO $ \s ->
    case compactResize# oldBuffer new_size s of
      s' -> (# s', () #)