{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell, ScopedTypeVariables,
             MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances,
             FlexibleInstances #-}
{-# 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 qualified Data.ByteString.Char8 as C

import Language.Pads.PadsPrinter

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

-- | 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]

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

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]


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

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

-- 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 :: Int -> 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 :: Int -> BitField
bitField_def _ = 0

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

-- type instance PadsArg Integer = ()
-- type instance Meta Integer = Base_md
-- instance Pads1 () Integer Base_md where
--     parsePP1 () = bitField_parseM
--     printFL1 () = bitField_printFL
--     def1 () = bitField_def


type Bits8 = Word8
type Bits8_md = Base_md

bits8_parseM :: Int -> 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


type Bits16 = Word16
type Bits16_md = Base_md

bits16_parseM :: Int -> 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


type Bits32 = Word32
type Bits32_md = Base_md

bits32_parseM :: Int -> 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


type Bits64 = Word64
type Bits64_md = Base_md

bits64_parseM :: Int -> 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


bits8_def  :: a -> Bits8
bits16_def :: a -> Bits16
bits32_def :: a -> Bits32
bits64_def :: a -> Bits64

bits8_def  _ = 0
bits16_def _ = 0
bits32_def _ = 0
bits64_def _ = 0

bits8_printFL  :: Int -> PadsPrinter (Bits8, md)
bits16_printFL :: Int -> PadsPrinter (Bits16, md)
bits32_printFL :: Int -> PadsPrinter (Bits32, md)
bits64_printFL :: Int -> PadsPrinter (Bits64, md)

bits8_printFL  _ (x, xmd) = fshow x
bits16_printFL _ (x, xmd) = fshow x
bits32_printFL _ (x, xmd) = fshow x
bits64_printFL _ (x, xmd) = fshow x

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

--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

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

--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

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

--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

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

--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



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

-- 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


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

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


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

--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

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

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

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

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


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

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

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

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

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

-- | 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)

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

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

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

-- | 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)

---- 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

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

-- | 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


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

-- | 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

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

-- | 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



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


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

eOF_printFL = eof_printFL

eOF_def :: EOF
eOF_def = ()

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



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)

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


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

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