{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell, ScopedTypeVariables,
             MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances,
             FlexibleInstances, UndecidableInstances, DeriveLift #-}
{-# OPTIONS_HADDOCK prune #-}
{-|
  Module      : Language.Pads.CoreBaseTypes
  Description : Core Pads base types with parsers
  Copyright   : (c) 2011
                Kathleen Fisher <kathleen.fisher@gmail.com>
                John Launchbury <john.launchbury@gmail.com>
  License     : MIT
  Maintainer  : Karl Cronburg <karl@cs.tufts.edu>
  Stability   : experimental

-}
module Language.Pads.CoreBaseTypes where

import Language.Pads.Generic
import Language.Pads.MetaData
import Language.Pads.PadsParser
import Language.Pads.RegExp
import Data.Maybe

import qualified Language.Pads.Source as S
import qualified Language.Pads.Errors as E
import qualified Data.ByteString as B
import           Data.ByteString.Internal
import qualified Data.ByteString.Char8 as C

import Language.Pads.PadsPrinter
import Language.Pads.Generation

import Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax
import Data.Data
import qualified Data.Map as M
import qualified Data.List as List
import Data.Word
import Data.Char as Char
import Data.Int
import Data.Bits

import Text.PrettyPrint.Mainland as PP
import Text.PrettyPrint.Mainland.Class

import Control.Monad
import Control.Monad.Reader
import System.IO.Unsafe (unsafePerformIO)


-- | Metadata type for a PADS Char
type Char_md = Base_md

-- | Monadic parser for a PADS Char
char_parseM :: PadsParser (Char, Base_md)
char_parseM  =
  handleEOF def "Char" $
  handleEOR def "Char" $ do
    c <- takeHeadP
    returnClean c

-- | Default value inserted by the parser for a PADS Char
char_def :: Char
char_def = 'X'

type instance PadsArg Char = ()
type instance Meta Char = Base_md
instance Pads1 () Char Base_md where
  parsePP1 () = char_parseM
  printFL1 () = char_printFL
  def1 () = char_def

char_printFL :: PadsPrinter (Char, md)
char_printFL (c,bmd) = addString [c]

char_genM :: PadsGen st Char
char_genM = randLetter

char_serialize :: Char -> CList
char_serialize c = toCL [CharChunk c]

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

type BitBool = Bool
type BitBool_md = Base_md

bitBool_parseM :: PadsParser (BitBool, Base_md)
bitBool_parseM =
    handleEOF False "BitBool" $
    handleEOR False "BitBool" $ do
        b <- takeBits8P 1
        returnClean (b == 1)

bitBool_def = False

bitBool_printFL :: PadsPrinter (BitBool, md)
bitBool_printFL (bb,bbmd) = fshow bb

bitBool_genM :: PadsGen st BitBool
bitBool_genM = randElem [False,True]

bitBool_serialize :: BitBool -> CList
bitBool_serialize b = toCL [BinaryChunk ((fromIntegral . fromEnum) b) 1]

-- type instance PadsArg Bool = ()
-- type instance Meta Bool = Base_md
-- instance Pads1 () Bool Base_md where
--     parsePP1 () = bitBool_parseM
--     printFL1 () = bitBool_printFL
--     def1 () = bitBool_def

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

type BitField = Integer
type BitField_md = Base_md

bitField_parseM :: Integral a => a -> PadsParser (BitField, Base_md)
bitField_parseM x =
    if   x < 0
    then returnError def (E.BitWidthError 0 (fromIntegral x))
    else handleEOF 0 "BitField" $
         handleEOR 0 "BitField" $ do
             b <- takeBitsP x
             returnClean b

bitField_def :: a -> BitField
bitField_def _ = 0

bitField_printFL :: Integral a => a -> PadsPrinter (BitField, md)
bitField_printFL _ (x, xmd) = fshow x

bitField_genM :: Integral a => a -> PadsGen st BitField
bitField_genM x = randIntegerBound (2^x - 1)

bitField_serialize :: Integral a => a -> BitField -> CList
bitField_serialize b v = toCL [BinaryChunk v (fromIntegral b)]


type Bits8 = Word8
type Bits8_md = Base_md

bits8_parseM :: Integral a => a -> PadsParser (Bits8, Base_md)
bits8_parseM x =
    if   x < 1 || x > 8
    then returnError 0 (E.BitWidthError 8 (fromIntegral x))
    else handleEOF 0 "Bits8" $
         handleEOR 0 "Bits8" $ do
             b <- takeBits8P x
             returnClean b

bits8_def :: a -> Bits8
bits8_def _ = 0

bits8_printFL  :: Integral a => a -> PadsPrinter (Bits8, md)
bits8_printFL  _ (x, xmd) = fshow x

bits8_genM :: Integral a => a -> PadsGen st Bits8
bits8_genM x = randNumBound (2^x - 1)

bits8_serialize :: Int -> Bits8 -> CList
bits8_serialize b v = toCL [BinaryChunk (fromIntegral v) b]


type Bits16 = Word16
type Bits16_md = Base_md

bits16_parseM :: Integral a => a -> PadsParser (Bits16, Base_md)
bits16_parseM x =
    if   x < 1 || x > 16
    then returnError 0 (E.BitWidthError 16 (fromIntegral x))
    else handleEOF 0 "Bits16" $
         handleEOR 0 "Bits16" $ do
             b <- takeBits16P x
             returnClean b

bits16_def :: a -> Bits16
bits16_def _ = 0

bits16_printFL :: Integral a => a -> PadsPrinter (Bits16, md)
bits16_printFL _ (x, xmd) = fshow x

bits16_genM :: Integral a => a -> PadsGen st Bits16
bits16_genM x = randNumBound (2^x - 1)

bits16_serialize :: Int -> Bits16 -> CList
bits16_serialize b v = toCL [BinaryChunk (fromIntegral v) b]


type Bits32 = Word32
type Bits32_md = Base_md

bits32_parseM :: Integral a => a -> PadsParser (Bits32, Base_md)
bits32_parseM x =
    if   x < 1 || x > 32
    then returnError 0 (E.BitWidthError 32 (fromIntegral x))
    else handleEOF 0 "Bits32" $
         handleEOR 0 "Bits32" $ do
             b <- takeBits32P x
             returnClean b

bits32_def :: a -> Bits32
bits32_def _ = 0

bits32_printFL :: Integral a => a -> PadsPrinter (Bits32, md)
bits32_printFL _ (x, xmd) = fshow x

bits32_genM :: Integral a => a -> PadsGen st Bits32
bits32_genM x = randNumBound (2^x - 1)

bits32_serialize :: Int -> Bits32 -> CList
bits32_serialize b v = toCL [BinaryChunk (fromIntegral v) b]


type Bits64 = Word64
type Bits64_md = Base_md

bits64_parseM :: Integral a => a -> PadsParser (Bits64, Base_md)
bits64_parseM x =
    if   x < 1 || x > 64
    then returnError 0 (E.BitWidthError 64 (fromIntegral x))
    else handleEOF 0 "Bits64" $
         handleEOR 0 "Bits64" $ do
             b <- takeBits64P x
             returnClean b

bits64_def :: a -> Bits64
bits64_def _ = 0

bits64_printFL :: Integral a => a -> PadsPrinter (Bits64, md)
bits64_printFL _ (x, xmd) = fshow x

bits64_genM :: Integral a => a -> PadsGen st Bits64
bits64_genM x = randNumBound (2^x - 1)

bits64_serialize :: Int -> Bits64 -> CList
bits64_serialize b v = toCL [BinaryChunk (fromIntegral v) b]

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

--type Int
type Int_md = Base_md

-- | Monadic parser for a PADS Int
int_parseM :: PadsParser (Int,Base_md)
int_parseM =
  handleEOF def "Int" $
  handleEOR def "Int" $ do
    c <- peekHeadP
    let isNeg = (c == '-')
    when isNeg (takeHeadP >> return ())
    digits <- satisfy Char.isDigit
    if not (null digits)
      then returnClean (digitListToInt isNeg digits)
      else returnError def (E.FoundWhenExpecting (mkStr c) "Int")

-- | Default value inserted by the parser for a PADS Int
int_def :: Int
int_def = 0

type instance PadsArg Int = ()
type instance Meta Int = Base_md
instance Pads1 () Int Base_md where
  parsePP1 () = int_parseM
  printFL1 () = int_printFL
  def1 () = int_def

int_printFL :: PadsPrinter (Int, Base_md)
int_printFL (i, bmd) = fshow i

int_genM :: PadsGen st Int
int_genM = randNum

int_serialize :: Int -> CList
int_serialize i = toCL $ map CharChunk $ show i

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

--type Integer
type Integer_md = Base_md

-- | Monadic parser for a PADS Integer
integer_parseM :: PadsParser (Integer,Base_md)
integer_parseM =
  handleEOF def "Integer" $
  handleEOR def "Integer" $ do
    c <- peekHeadP
    let isNeg = (c == '-')
    when isNeg (takeHeadP >> return ())
    digits <- satisfy Char.isDigit
    if not (null digits)
      then returnClean (toEnum $ digitListToInt isNeg digits)
      else returnError def (E.FoundWhenExpecting (mkStr c) "Integer")

-- | Default value inserted by the parser for a PADS Integer
integer_def :: Integer
integer_def = 0

type instance PadsArg Integer = ()
type instance Meta Integer = Base_md
instance Pads1 () Integer Base_md where
  parsePP1 () = integer_parseM
  printFL1 () = integer_printFL
  def1 () = integer_def

integer_printFL :: PadsPrinter (Integer, Base_md)
integer_printFL (i, bmd) = fshow i

integer_genM :: PadsGen st Integer
integer_genM = randInteger

integer_serialize :: Integer -> CList
integer_serialize i = toCL $ map CharChunk $ show i

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

--type Float
type Float_md = Base_md

-- | Monadic parser for a PADS Float, e.g. "-3.1415"
float_parseM :: PadsParser (Float,Base_md)
float_parseM =
  handleEOF def "Float" $
  handleEOR def "Float" $ do
    -- Get leading sign
    c <- peekHeadP
    let isNeg = (c == '-')
    when isNeg (takeHeadP >> return ())
    let sign = if isNeg then "-" else ""
    -- Get digits before any dot
    digits1 <- satisfy Char.isDigit
    -- Get optional dot
    d <- peekHeadP
    let hasDot = (d == '.')
    when hasDot (takeHeadP >> return ())
    let dec = if hasDot then "." else ""
    -- Get digits after dot
    digits2 <- satisfy Char.isDigit
    -- Get optional exponent marker
    e <- peekHeadP
    let hasExp = (e == 'e')
    when hasExp (takeHeadP >> return ())
    let exp = if hasExp then "e" else ""
    -- Get optional exponent sign
    es <- peekHeadP
    let hasESign = (es == '-')
    when hasESign (takeHeadP >> return ())
    let expSign = if hasESign then "-" else ""
    -- Get digits in the exponent
    digits3 <- satisfy Char.isDigit
    -- As long as the double had digits
    if not (null digits1)
      then returnClean (read (sign ++digits1++dec++digits2++exp++expSign++digits3))
      else returnError def (E.FoundWhenExpecting (mkStr c) "Float")

-- | Default value inserted by the parser for a PADS Float
float_def :: Float
float_def = 0

type instance PadsArg Float = ()
type instance Meta Float = Base_md
instance Pads1 () Float Base_md where
  parsePP1 () = float_parseM
  printFL1 () = float_printFL
  def1 () = float_def

float_printFL :: PadsPrinter (Float, Base_md)
float_printFL (d, bmd) = fshow d

float_genM :: PadsGen st Float
float_genM = randNum

float_serialize :: Float -> CList
float_serialize f = toCL $ map CharChunk $ show f

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

--type Double
type Double_md = Base_md

-- | Monadic parser for a textual PADS Double, e.g. "-3.1415"
double_parseM :: PadsParser (Double,Base_md)
double_parseM =
  handleEOF def "Double" $
  handleEOR def "Double" $ do
    -- Get leading sign
    c <- peekHeadP
    let isNeg = (c == '-')
    when isNeg (takeHeadP >> return ())
    let sign = if isNeg then "-" else ""
    -- Get digits before any dot
    digits1 <- satisfy Char.isDigit
    -- Get optional dot
    d <- peekHeadP
    let hasDot = (d == '.')
    when hasDot (takeHeadP >> return ())
    let dec = if hasDot then "." else ""
    -- Get digits after dot
    digits2 <- satisfy Char.isDigit
    -- Get optional exponent marker
    e <- peekHeadP
    let hasExp = (e == 'e')
    when hasExp (takeHeadP >> return ())
    let exp = if hasExp then "e" else ""
    -- Get optional exponent sign
    es <- peekHeadP
    let hasESign = (es == '-')
    when hasESign (takeHeadP >> return ())
    let expSign = if hasESign then "-" else ""
    -- Get digits in the exponent
    digits3 <- satisfy Char.isDigit
    -- As long as the double had digits
    if not (null digits1)
      then returnClean (read (sign ++digits1++dec++digits2++exp++expSign++digits3))
      else returnError def (E.FoundWhenExpecting (mkStr c) "Double")

-- | Default value inserted by the parser for a PADS Float
double_def :: Double
double_def = 0

type instance PadsArg Double = ()
type instance Meta Double = Base_md
instance Pads1 () Double Base_md where
  parsePP1 () = double_parseM
  printFL1 () = double_printFL
  def1 () = 0

double_printFL :: PadsPrinter (Double, Base_md)
double_printFL (d, bmd) = fshow d

double_genM :: PadsGen st Double
double_genM = randNum

double_serialize :: Double -> CList
double_serialize d = toCL $ map CharChunk $ show d

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

-- tries to parse @a@ without consuming the input string
type Try a = a
type Try_md a_md = (Base_md, a_md)

try_parseM :: PadsMD md => PadsParser (rep,md) -> PadsParser (Try rep, Try_md md)
try_parseM p = do
  (rep,md) <- parseTry p
  return (rep, (cleanBasePD, md))

try_printFL :: PadsPrinter (a,a_md) -> PadsPrinter (Try a,Try_md a_md)
try_printFL p _ = printNothing

try_def :: a -> Try a
try_def d = d

try_genM :: PadsGen st a -> PadsGen st (Try a)
try_genM g = g >>= return

--try_serialize :: Try a -> CList
try_serialize = id


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

type Digit = Int
type Digit_md = Base_md

-- | Monadic parser for a PADS Digit according to @'isDigit'@
digit_parseM :: PadsParser (Digit, Base_md)
digit_parseM  =
  handleEOF def "Pdigit" $
  handleEOR def "Pdigit" $ do
    c <- takeHeadP
    if isDigit c
      then returnClean (digitToInt c)
      else returnError def (E.FoundWhenExpecting [c] "Digit")

-- | Default value inserted by the parser for a PADS Digit
digit_def :: Digit
digit_def = 0

digit_printFL :: PadsPrinter (Digit, Base_md)
digit_printFL (i, bmd) = fshow i

digit_genM :: PadsGen st Digit
digit_genM = randNumBound 9

digit_serialize :: Digit -> CList
digit_serialize d = toCL $ map CharChunk $ show d


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

--type String
type String_md = Base_md

string_parseM :: PadsParser (String, Base_md)
string_parseM = do
  document <- getAllBinP
  returnClean $ C.unpack document

-- | Default value inserted by the parser for a PADS String
string_def = ""

type instance PadsArg String = ()
type instance Meta String = Base_md
instance Pads1 () String Base_md where
  parsePP1 () = string_parseM
  printFL1 () = string_printFL
  def1 () = string_def

string_printFL :: PadsPrinter (String, Base_md)
string_printFL (str, bmd) = addString str

string_genM :: PadsGen st String
string_genM = stringVW_genM 100

string_serialize :: String -> CList
string_serialize s = toCL $ map CharChunk s

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


newtype Text = Text S.RawStream
  deriving (Eq, Show, Data, Typeable, Ord)
type Text_md = Base_md

text_parseM :: PadsParser (Text, Base_md)
text_parseM = do
  document <- getAllBinP
  returnClean (Text document)

instance Pretty Text where
  ppr (Text str) = text "ASCII"

text_def :: Text
text_def = Text $ B.pack []

type instance PadsArg Text = ()
type instance Meta Text = Base_md
instance Pads1 () Text Base_md where
  parsePP1 () = text_parseM
  printFL1 () = text_printFL
  def1 () = text_def

text_printFL :: PadsPrinter (Text, Base_md)
text_printFL (Text str, bmd) = addBString str

text_genM :: PadsGen st Text
text_genM = Text <$> B.pack <$> (map S.chrToWord8) <$> stringVW_genM 500

text_serialize :: Text -> CList
text_serialize (Text b) = toCL $ ((map (CharChunk . S.word8ToChr)) . B.unpack) b

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

newtype Binary = Binary S.RawStream
  deriving (Eq, Show, Data, Typeable, Ord)
type Binary_md = Base_md

binary_parseM :: PadsParser (Binary, Base_md)
binary_parseM = do
  document <- getAllBinP
  returnClean (Binary document)

instance Pretty Binary where
  ppr (Binary str) = text "Binary"

binary_def :: Binary
binary_def = Binary $ B.pack []

type instance PadsArg Binary = ()
type instance Meta Binary = Base_md
instance Pads1 () Binary Base_md where
  parsePP1 () = binary_parseM
  printFL1 () = binary_printFL
  def1 () = binary_def

binary_printFL :: PadsPrinter (Binary, Base_md)
binary_printFL (Binary bstr, bmd) = addBString bstr


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

-- | string with end character. Ex:
--
-- > StringC ','
type StringC = String
type StringC_md = Base_md

stringC_parseM :: Char -> PadsParser (StringC, Base_md)
stringC_parseM c =
  handleEOF (stringC_def c) "StringC" $
  handleEOR (stringC_def c) "StringC" $ do
    str <- satisfy (\c'-> c /= c')
    returnClean str

stringC_def c = ""

stringC_printFL :: Char -> PadsPrinter (StringC, Base_md)
stringC_printFL c (str, bmd) = addString str

stringC_genM :: Char -> PadsGen st StringC
stringC_genM c = do
  i <- randNumBound 500
  replicateM i (randLetterExcluding c)

stringC_serialize :: Char -> StringC -> CList
stringC_serialize c s = (string_serialize s) `cAppend` (toCL [CharChunk c])

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


-- | string of fixed length
type StringFW = String
type StringFW_md = Base_md

stringFW_parseM :: Int -> PadsParser (StringFW, Base_md)
stringFW_parseM 0 = returnClean ""
stringFW_parseM n =
  handleEOF (stringFW_def n) "StringFW" $
  handleEOR (stringFW_def n) "StringFW" $ do
    str <- takeP n
    if (length str) == n
      then returnClean str
      else returnError (stringFW_def n) (E.Insufficient (length str) n)

stringFW_def :: Int -> StringFW
stringFW_def n = replicate n 'X'

stringFW_printFL :: Int -> PadsPrinter (StringFW, Base_md)
stringFW_printFL n (str, bmd)  = addString (take n str)

stringFW_genM :: Int -> PadsGen st StringFW
stringFW_genM i = replicateM i randLetter

stringFW_serialize :: Int -> StringFW -> CList
stringFW_serialize _ = string_serialize


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

-- | string of variable length
type StringVW = String
type StringVW_md = Base_md

stringVW_parseM :: Int -> PadsParser (StringVW, Base_md)
stringVW_parseM 0 = returnClean ""
stringVW_parseM n =
  handleEOF (stringVW_def n) "StringVW" $
  handleEOR (stringVW_def n) "StringVW" $ do
    str <- takeP n
    returnClean str

stringVW_def :: Int -> StringVW
stringVW_def n = replicate n 'X'

stringVW_printFL :: Int -> PadsPrinter (StringVW, Base_md)
stringVW_printFL n (str, bmd)  = addString (take n str)

stringVW_genM :: Int -> PadsGen st StringVW
stringVW_genM x = do
  i <- randNumBound x
  replicateM i randLetter

stringVW_serialize :: Int -> StringVW -> CList
stringVW_serialize i s = string_serialize s

---- string of variable length (end if EOR)
--type StringVW = String
--type StringVW_md = Base_md
--
--stringVW_parseM :: (Bool,Int) -> PadsParser (StringVW, Base_md)
--stringVW_parseM (endIfEOR,0) = returnClean ""
--stringVW_parseM (endIfEOR,n) = do
--  let (doEOF, doEOR) = if endIfEOR then (checkEOF, checkEOR) else (handleEOF, handleEOR)
--  doEOF "" "StringVW" $ doEOR "" "StringVW" $ do
--    c1 <- takeHeadP
--    (rest, rest_md) <- stringVW_parseM (endIfEOR,pred n)
--    return (c1:rest, rest_md)
--
--stringVW_def (endIfEOR,n) = replicate n 'X'
--
--stringVW_printFL :: (Bool,Int) -> PadsPrinter (StringVW, Base_md)
--stringVW_printFL (endIfEOR,n) (str, bmd)  = addString (take n str)

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

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

-- | string with matching expression. For example:
--
-- > [pads| type StrME = StringME 'a+' |]
type StringME = String
type StringME_md = Base_md

stringME_parseM :: RE -> PadsParser (StringME, Base_md)
stringME_parseM re =
  handleEOF (stringME_def re) "StringME" $ do
    match <- regexMatchP re
    case match of
      Just str -> returnClean str
      Nothing  -> returnError (stringME_def re) (E.RegexMatchFail (show re))

stringME_def (RE re) = "" -- should invert the re
stringME_def (REd re d) = d

stringME_printFL :: RE -> PadsPrinter (StringME, Base_md)
stringME_printFL re (str, bmd) = addString str
           -- We're not likely to check that str matches re

stringME_genM :: RE -> PadsGen st StringME
stringME_genM _
  = error $ "stringME_genM unimplemented: consider using the workaround \"type "
         ++ "XYZ = obtain StringME (RE) from StringME (RE) using <| "
         ++ "(const id, id) |> generator (gen)\" in your description to "
         ++ "provide your own regex-specific generator."

stringME_serialize :: RE -> StringME -> CList
stringME_serialize _ s = string_serialize s

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

-- | string matching given native regex. PADS uses posix regex (from the
--   regex-posix package). For example:
--
-- > [pads| StringSE <| RE "b|c" |>|]
type StringSE = String
type StringSE_md = Base_md

stringSE_parseM :: RE -> PadsParser (StringSE, Base_md)
stringSE_parseM re =
  checkEOF (stringSE_def re) "StringSE" $
  checkEOR (stringSE_def re) "StringSE" $ do
    match <- regexStopP re
    case match of
      Just str -> returnClean str
      Nothing  -> returnError (stringSE_def re) (E.RegexMatchFail (show re))

stringSE_def (RE re) = "" -- should invert the re
stringSE_def (REd re d) = d

stringSE_printFL :: RE -> PadsPrinter (StringSE, Base_md)
stringSE_printFL re (str, bmd) = addString str

stringSE_genM :: RE -> PadsGen st StringSE
stringSE_genM r
  = error $ "stringSE_genM unimplemented: consider using the workaround \"type "
         ++ "XYZ = obtain StringSE (" ++ show r ++ ") from StringSE ("
         ++ show r ++ ") using <| (const id, id) |> generator (gen)\" in your "
         ++ "description to provide your own regex-specific generator."

stringSE_serialize :: RE -> StringSE -> CList
stringSE_serialize _ s = string_serialize s


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

-- | string with a predicate. For example:
--
-- > [pads| type Digits = StringP Char.isDigit |]
type StringP = String
type StringP_md = Base_md

stringP_parseM :: (Char -> Bool) -> PadsParser (StringP, Base_md)
stringP_parseM p =
  handleEOF (stringP_def p) "StringP" $
  handleEOR (stringP_def p) "StringP" $ do
    str <- satisfy p
    returnClean str

stringP_def _ = ""

stringP_printFL :: (Char -> Bool) -> PadsPrinter (StringP, Base_md)
stringP_printFL p (str, bmd) = addString str

stringP_genM :: (Char -> Bool) -> PadsGen st StringP
stringP_genM _
  = error $ "stringP_genM unimplemented: consider using the workaround \"type "
         ++ "XYZ = obtain StringP (pred) from StringP (pred) using <| "
         ++ "(const id, id) |> generator (gen)\" in your description to "
         ++ "provide your own predicate-specific generator."


stringP_serialize :: (Char -> Bool) -> StringP -> CList
stringP_serialize _ s = string_serialize s


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

-- | string predicate with escape condition
type StringPESC = String
type StringPESC_md = Base_md

stringPESC_parseM :: (Bool, (Char, [Char])) -> PadsParser(StringPESC, Base_md)
stringPESC_parseM arg @ (endIfEOR, (escape, stops)) =
 let (doEOF, doEOR) = if endIfEOR then (checkEOF, checkEOR) else (handleEOF, handleEOR)
 in
  doEOF "" "StringPESC" $
  doEOR "" "StringPESC" $ do
    { c1 <- peekHeadP
    ; if c1 `elem` stops then
         returnClean ""
      else if c1 == escape then do
         { takeHeadP
         ; doEOF [c1] "StringPESC" $
           doEOR [c1] "StringPESC" $ do
            { c2 <- takeHeadP
            ; if (c2 == escape) || (c2 `elem` stops) then do
                   { (rest, rest_md) <- stringPESC_parseM arg
                   ;  return (c2:rest, rest_md)
                   }
              else do
                   { (rest, rest_md) <- stringPESC_parseM arg
                   ; return (c1:c2:rest, rest_md)
                   }
            }
         } else do
            { c1 <- takeHeadP
            ; (rest, rest_md) <- stringPESC_parseM arg
            ; return (c1:rest, rest_md)
            }
    }

stringPESC_def :: (Bool, (Char, [Char])) -> String
stringPESC_def arg@(endIfEOR, (escape, stops)) = ""

stringPESC_printFL :: (Bool, (Char, [Char])) -> PadsPrinter (StringPESC, Base_md)
stringPESC_printFL (_, (escape, stops)) (str, bmd) =
  let replace c = if c `elem` stops then escape : [c] else [c]
      newStr =  concat (map replace str)
  in addString newStr

stringPESC_genM :: (Bool, (Char, [Char])) -> PadsGen st StringPESC
stringPESC_genM _ = error "stringPESC_genM: unimplemented"

stringPESC_serialize :: (Bool, (Char, [Char])) -> StringPESC -> CList
stringPESC_serialize _ s = string_serialize s

-----------------------------------------------------------------
-- Non-byte-aligned (NB) types


type CharNB = Char
type CharNB_md = Base_md

charNB_parseM :: PadsParser (CharNB, Base_md)
charNB_parseM =
    handleEOF def "CharNB" $
    handleEOR def "CharNB" $ do
        c <- takeBitsP 8
        returnClean (S.word8ToChr (fromIntegral c :: Word8))

charNB_def :: Char
charNB_def = char_def

charNB_printFL :: PadsPrinter (CharNB, md)
charNB_printFL (c, bmd) = addString [c]

charNB_genM :: PadsGen st CharNB
charNB_genM = char_genM

charNB_serialize :: CharNB -> CList
charNB_serialize = char_serialize

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


type StringNB = String
type StringNB_md = Base_md

stringNB_parseM :: PadsParser (String, Base_md)
stringNB_parseM = do
    str <- drainSourceNBP
    returnClean str

stringNB_def = string_def

stringNB_printFL :: PadsPrinter (String, Base_md)
stringNB_printFL = string_printFL

stringNB_genM :: PadsGen st StringNB
stringNB_genM = string_genM

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

type StringCNB = String
type StringCNB_md = Base_md

stringCNB_parseM :: Char -> PadsParser (StringCNB, Base_md)
stringCNB_parseM c =
    handleEOF (stringCNB_def c) "StringCNB" $
    handleEOR (stringCNB_def c) "StringCNB" $ do
        str <- satisfyNBP (\c' -> c /= c')
        returnClean str

stringCNB_def :: Char -> StringCNB
stringCNB_def = stringC_def

stringCNB_printFL :: Char -> PadsPrinter (StringCNB, Base_md)
stringCNB_printFL = stringC_printFL

stringCNB_genM :: Char -> PadsGen st StringCNB
stringCNB_genM = stringC_genM

stringCNB_serialize :: Char -> StringC -> CList
stringCNB_serialize = stringC_serialize


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

type StringFWNB = String
type StringFWNB_md = Base_md

stringFWNB_parseM :: Int -> PadsParser (StringFW, Base_md)
stringFWNB_parseM 0 = returnClean ""
stringFWNB_parseM n =
    handleEOF (stringFWNB_def n) "StringFWNB" $
    handleEOR (stringFWNB_def n) "StringFWNB" $ do
        str <- takeBytesNBP n
        let str' = map S.word8ToChr (B.unpack str)
        if (length str') == n
            then returnClean str'
            else returnError (stringFWNB_def n) (E.Insufficient (length str') n)

stringFWNB_def :: Int -> StringFW
stringFWNB_def n = replicate n 'X'

stringFWNB_printFL :: Int -> PadsPrinter (StringFW, Base_md)
stringFWNB_printFL = stringFW_printFL

stringFWNB_genM :: Int -> PadsGen st StringFWNB
stringFWNB_genM = stringFW_genM

stringFWNB_serialize :: Int -> StringFWNB -> CList
stringFWNB_serialize _ = string_serialize

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

type BytesNB = S.RawStream
type BytesNB_md = Base_md

bytesNB_parseM :: Int -> PadsParser (BytesNB, BytesNB_md)
bytesNB_parseM n =
    handleEOF (def1 n) "BytesNB" $
    handleEOR (def1 n) "BytesNB" $ do
        bytes <- takeBytesNBP n
        if B.length bytes == n
            then returnClean bytes
            else returnError (def1 n) (E.Insufficient (B.length bytes) n)

bytesNB_printFL :: Int -> PadsPrinter (BytesNB, BytesNB_md)
bytesNB_printFL = bytes_printFL

bytesNB_def :: Int -> BytesNB
bytesNB_def = bytes_def

bytesNB_genM :: Int -> PadsGen st BytesNB
bytesNB_genM = bytes_genM

bytesNB_serialize :: Int -> BytesNB -> CList
bytesNB_serialize = bytes_serialize

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


-- | Chunks represent an abstraction of literal data, and allow for easy
-- consumption and concatenation into one ByteString of data, which can be
-- written to disk. Each BinaryChunk represents the value val .&. (2^bits - 1)
data Chunk = CharChunk   Char
           | BinaryChunk { val :: Integer, bits :: Int }
    deriving (Eq, Show, Lift)

-- | fromChunks provides a translation from Chunks to a list of bytes. It
-- accomplishes this in time linear to the length of the list of Chunks. It
-- converts each chunk into "bits" (a list of 1's and 0's), then splits that
-- into "bytes" (lists of length 8 each) to simplify combination in non-byte-
-- aligned cases.
fromChunks :: [Chunk] -> B.ByteString
fromChunks cs = let
  bits = concat $ chunksToBits cs
  toPad = case (8 - ((length bits) `mod` 8)) of 8 -> 0; x -> x
  padding = replicate toPad 0
  bytes = asBytes $ bits ++ padding
  in if   (length (bits ++ padding) `mod` 8) /= 0
     then error "fromChunks: bug in binary conversion"
     else B.pack $ map fromBytes bytes
  where
    -- | Dispatches to toPaddedBits depending on Chunk type
    chunksToBits :: [Chunk] -> [[Word8]]
    chunksToBits [] = []
    chunksToBits ((CharChunk c):cs) =
      (toPaddedBits (fromEnum c) 8) : chunksToBits cs
    chunksToBits ((BinaryChunk v b):cs) =
      (toPaddedBits v            b) : chunksToBits cs

    -- | Ensure every value includes the number of bits it's meant to, since
    -- toBits won't include 0s when necessary
    toPaddedBits :: Integral a => a -> Int -> [Word8]
    toPaddedBits x padTo = let
      x' = toBits x []
      padding = replicate (padTo - length x') 0
      in if   (padTo - length x') < 0
         then drop (abs $ padTo - length x') x'
         else padding ++ x'

    -- | Straightforward decimal-to-bits conversion
    toBits :: Integral a => a -> [Word8] -> [Word8]
    toBits 0 [] = [0]
    toBits 0 bs = bs
    toBits x bs = toBits (x `div` 2) (fromIntegral x `mod` 2 : bs)

    -- | Split list of 1s and 0s into lists of length 8 each
    asBytes :: [Word8] -> [[Word8]]
    asBytes [] = []
    asBytes xs = (take 8 xs) : (asBytes $ drop 8 xs)

    -- | Convert a list of 8 bits into a decimal byte
    fromBytes :: [Word8] -> Word8
    fromBytes bs = let
      withPowers = zip bs (reverse [0..7])
      in foldr1 (+) (map (\(b,p) -> b * 2^p) withPowers)

type CList = [Chunk] -> [Chunk]

-- For debugging mostly
instance Show CList where
  show cl = show $ fromCL cl

cAppend :: CList -> CList -> CList
cs1 `cAppend` cs2 = cs1 . cs2

cConcat :: [CList] -> CList
cConcat cl = foldr cAppend id cl

toCL :: [Chunk] -> CList
toCL cs = (cs ++)

fromCL :: CList -> [Chunk]
fromCL cl = cl []

class ExpSerialize a where
  exp_serialize :: a -> CList

instance ExpSerialize Char where
  exp_serialize = char_serialize

instance ExpSerialize [Char] where
  exp_serialize = string_serialize

instance ExpSerialize RE where
  exp_serialize _ = string_serialize "RegEx Literal"

-- This instance doesn't overlap with the above three, though GHC's constraint-
-- matching logic obscures that fact. Since a. no other instance is "strictly
-- more specific" and b. this instance is the only incoherent one, the
-- INCOHERENT pragma can be applied safely here without fear of undefined
-- behavior (likely failure) by GHC choosing a random/incorrect instance. See
-- the GHC user's guide at section 10.8.3.6 for more details.
instance {-# INCOHERENT #-} (Num a, Show a) => ExpSerialize a where
  exp_serialize x = toCL $ map CharChunk $ show x

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

class LitParse a where
  litParse :: a -> PadsParser ((), Base_md)
  litPrint :: a -> FList

strLit_parseM :: String -> PadsParser ((), Base_md)
strLit_parseM s =
  handleEOF () s $
  handleEOR () s $ do
    match <- scanStrP s
    case match of
      Just []   -> returnClean ()
      Just junk -> returnError () (E.ExtraBeforeLiteral s)
      Nothing   -> returnError () (E.MissingLiteral     s)

strLit_printFL :: String -> FList
strLit_printFL str = addString str

instance LitParse Char where
  litParse = charLit_parseM
  litPrint = charLit_printFL

charLit_parseM :: Char -> PadsParser ((),Base_md)
charLit_parseM c =
  handleEOF () (mkStr c) $
  handleEOR () (mkStr c) $ do
    c' <- takeHeadP
    if c == c' then returnClean () else do
      foundIt <- scanP c
      returnError () (if foundIt
                      then E.ExtraBeforeLiteral (mkStr c)
                      else E.MissingLiteral     (mkStr c))

charLit_printFL :: Char -> FList
charLit_printFL c = addString [c]

instance LitParse String where
  litParse = strLit_parseM
  litPrint = strLit_printFL


instance LitParse RE where
  litParse = reLit_parseM
  litPrint = reLit_printFL

reLit_parseM :: RE -> PadsParser ((), Base_md)
reLit_parseM re = do
  (match, md) <- stringME_parseM re
  if numErrors md == 0
    then return ((), md)
    else badReturn ((), md)

reLit_printFL :: RE -> FList
reLit_printFL (RE re) = addString "--REGEXP LITERAL-- "
reLit_printFL (REd re def) = addString def

-- | End of File
type EOF = ()
type EOF_md = Base_md

eof_parseM :: PadsParser (EOF, Base_md)
eof_parseM = do
  isEof <- isEOFP
  if isEof then returnClean ()
           else returnError () (E.ExtraBeforeLiteral "Eof")

-- | End of Record
type EOR = ()
type EOR_md = Base_md

eor_parseM :: PadsParser (EOR, Base_md)
eor_parseM =
   handleEOF () "EOR" $ do
   isEor <- isEORP
   if isEor then doLineEnd
     else returnError () (E.LineError "Expecting EOR")

eor_printFL :: (EOR,Base_md) -> FList
eor_printFL = const eorLit_printFL

eOR_printFL = eor_printFL

eOR_def :: EOR
eOR_def = ()

eof_printFL :: (EOF,Base_md) -> FList
eof_printFL = const eofLit_printFL

eOR_genM :: PadsGen st EOR
eOR_genM = return eOR_def

eOR_serialize :: CList
eOR_serialize = toCL [CharChunk '\n']

eOF_printFL = eof_printFL

eOF_def :: EOF
eOF_def = ()

eOF_genM :: PadsGen st EOF
eOF_genM = return eOF_def

eOF_serialize :: CList
eOF_serialize = toCL []

eorLit_printFL :: FList
eorLit_printFL = printEOR

eofLit_printFL ::  FList
eofLit_printFL = printEOF

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

newtype Void = Void ()
  deriving (Eq, Show, Data, Typeable, Ord)
type Void_md = Base_md

void_parseM :: PadsParser (Void, Base_md)
void_parseM = returnClean (Void ())

void_def :: Void
void_def = Void ()

type instance Meta Void = Base_md
instance Pads1 () Void Base_md where
  parsePP1 () = void_parseM
  printFL1 () = void_printFL
  def1 () = void_def

void_printFL :: PadsPrinter (Void,Base_md)
void_printFL v = nil

void_genM :: PadsGen st Void
void_genM = return void_def

void_serialize :: CList
void_serialize = toCL []



pstrLit_printQ :: String -> FList
pstrLit_printQ str = addString str

tuple_printQ :: (String, String, String) -> FList
tuple_printQ (s1,s2,s3) = pstrLit_printQ s1 +++ pstrLit_printQ s2 +++ pstrLit_printQ s3

rtuple_printQ :: (String, String, String) -> FList
rtuple_printQ ss = tuple_printQ ss +++ (addString ['\n'])

list_printQ :: [(String,String,String)] -> FList
list_printQ [] =  nil
list_printQ (item:items) = rtuple_printQ item +++ list_printQ items








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

handleEOF val str p
  = do { isEof <- isEOFP
       ; if isEof then
           returnError val (E.FoundWhenExpecting "EOF" str)
         else p}

handleEOR val str p
  = do { isEor <- isEORP
       ; if isEor then
           returnError val (E.FoundWhenExpecting "EOR" str)
         else p}

checkEOF val str p
  = do { isEof <- isEOFP
       ; if isEof then
           returnClean val
         else p}

checkEOR val str p
  = do { isEor <- isEORP
       ; if isEor then
           returnClean val
         else p}

----------------------------------
-- BINARY TYPES --
----------------------------------


type Bytes    = S.RawStream
type Bytes_md = Base_md

bytes_parseM :: Int -> PadsParser (Bytes,Bytes_md)
bytes_parseM n =
  handleEOF (def1 n) "Bytes" $
  handleEOR (def1 n) "Bytes" $ do
    bytes <- takeBytesP n
    if B.length bytes == n
      then returnClean bytes
      else returnError (def1 n) (E.Insufficient (B.length bytes) n)

bytes_printFL :: Int -> PadsPrinter (Bytes, Bytes_md)
bytes_printFL n (bs, bmd) =
  addBString bs

bytes_def :: Int -> Bytes
bytes_def i = B.pack $ replicate i (0::Word8)

bytes_genM :: Int -> PadsGen st Bytes
bytes_genM i = do
  w8s <- replicateM i $ randNumBound (255 :: Word8)
  return $ B.pack w8s

bytes_serialize :: Int -> Bytes -> CList
bytes_serialize _ bs = toCL $ map (CharChunk . S.word8ToChr) $ B.unpack bs

type instance PadsArg Bytes = Int
type instance Meta Bytes = Bytes_md
instance Pads1 Int Bytes Bytes_md where
  parsePP1 = bytes_parseM
  printFL1 = bytes_printFL
  def1 i = bytes_def i


{- Helper functions -}
mkStr c = "'" ++ [c] ++ "'"

-- | Some PADS types, PConstrain for instance, are designed to have access to
-- parsed metadata, stored as the variable md. In parsing, metadata is created
-- and supplied to the constraint at the correct time in the generated parsing
-- functions.
-- However, during generation of generation functions, no metadata exists.
-- Providing this variable assignment prevents compile time errors of functions
-- with predicates that refer to md, and is safe wrt parsing predicates
-- because the md variables in their generated code are bound in lambdas.
md = Base_md 0 Nothing