snaplet-mongoDB / src / Snap / Snaplet / MongoDB / Parse.hs

root df0ea16 




















































































































































































































































































































































































































































































































  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
-- |
-- Module      : Snap.Snaplet.MongoDB.Parse
-- Description : Parser for MongoDB documents.
-- Copyright   : (C) 2011 Massive Tactical Limited
-- License     : BSD3
--
-- Maintainer  : Blake Rain <blake.rain@massivetactical.com>
-- Stability   : Provisional
-- Portability : Portable
--
-- Provides a quasi-quote parser for MongoDB documents.
--

module Snap.Snaplet.MongoDB.Parse
       ( mongo
       ) where

import           Control.Applicative
--import qualified Data.Bson as BSON
--import           Data.Bson (Field ((:=)))
import           Data.Char (isSpace, digitToInt)
import           Data.Text (Text)
import           Language.Haskell.TH.Syntax
import           Language.Haskell.TH.Syntax.Internals
import           Language.Haskell.TH.Quote
import qualified Language.Haskell.Exts as H
import           Snap.Snaplet.MongoDB.MongoValue
import           Snap.Snaplet.MongoDB.MongoEntity
import           Text.Parsec hiding (many, (<|>))

mongo :: QuasiQuoter
mongo = QuasiQuoter { quoteExp = mongoQuote }

mongoQuote :: String -> Q Exp
mongoQuote input = do
  expr <- runParserT parseMongo () "" input
  case expr of
    Left err -> error $ show err
    Right  e -> return e


type Parser = ParsecT String () Q

parseMongo :: Parser Exp
parseMongo = do
  doc <- whitespace *> topObjectDef
  return ((VarE 'toDocument) `AppE` doc)
  where
    topObjectDef =
      singleField <|> multipleFields
    singleField =
      (ListE . (: [])) <$> objectField
    multipleFields =
      objectDef

whitespace :: Parser ()
whitespace =
  skipMany . satisfy $ isSpace

lexeme :: Parser a -> Parser a
lexeme p =
  p <* whitespace

objectDef :: Parser Exp
objectDef =
     (lexeme (char '{') <?> "'{' at start of JSON object")
  *> (lexeme objectFields) <*
     (lexeme (char '}') <?> "'}' at end of JSON object")

objectFields :: Parser Exp
objectFields = do
  ListE <$> sepBy objectField (lexeme $ char ',')

objectField :: Parser Exp
objectField = do
  name  <- lexeme (identifier <|> stringLiteral) <?> "identifier for field definition"
  _     <- lexeme (char ':')
  val   <- lexeme (fieldValue <|> arrayValue <|> objectDef) <?> ("value for field `" ++ name ++ "'")
  
  return (InfixE (Just . LitE . StringL $ name)
                 (ConE '(:=))
                 (Just (AppE (VarE 'toValue) val)))

arrayValue :: Parser Exp
arrayValue = do
     (lexeme (char '[') <?> "'[' at start of JSON array")
  *> (lexeme arrayElements) <*
     (lexeme (char ']') <?> "']' at end of JSON array")
  where
    arrayElements = 
      ListE . map ((VarE 'toValue) `AppE`) <$> sepBy (fieldValue <|> arrayValue <|> objectDef) (lexeme $ char ',')
     

fieldValue :: Parser Exp
fieldValue = do
  (stringValue <|> altBaseIntegerValue <|> numericalValue <|> boolNullValue <|> pasteValue) <?> "field value"
  where
    stringValue =
      ((`SigE` (ConT ''Text)) . LitE . StringL) <$> stringLiteral

    numericalValue = do
      int <- decimal
      rl  <- do
        (Left . (+ fromIntegral int) <$> denom) <|> pure (Right int)
      mEx <- option Nothing (Just <$> (oneOf "eE" *> (option id ((char '-' *> pure negate) <|> (char '+' *> pure id)) <*> decimal)))
      case mEx of
        Just ex -> pure $! ((`SigE` (ConT ''Double)) . LitE . RationalL. toRational $ either id fromIntegral rl * (10 ** fromIntegral ex))
        Nothing -> 
          case rl of
            Left  f -> pure $! ((`SigE` (ConT  ''Double)) . LitE . RationalL . toRational $ f)
            Right i -> pure $! ((`SigE` (ConT ''Integer)) . LitE . IntegerL               $ i)
    altBaseIntegerValue =
      ((`SigE` (ConT ''Integer)) . LitE . IntegerL) <$> (hexadecimal <|> octal <|> binary)
    hexadecimal = try (char '0' *> oneOf "xX" *> numberBuilder 16 hexDigit)
    octal       = try (char '0' *> oneOf "oO" *> numberBuilder  8 octDigit)
    binary      = try (char '0' *> oneOf "bB" *> numberBuilder 2 (char '0' <|> char '1'))
    denom =
      let op = ((/ 10) .) . ((+) . (fromIntegral . digitToInt))
      in pure (foldr op 0.0) <*> (char '.' *> many1 digit)
    
    boolNullValue =
      identifier >>= (\i -> case i of
                             "true"  -> pure . ConE $ 'True
                             "false" -> pure . ConE $ 'False
                             "null"  -> pure . ConE $ '()
                             _       -> unexpected i)
    pasteValue = do
      text <- (char '#' *> betweenBraces)
      case H.parseExp text of
        H.ParseOk       expr -> return (mapExpToTH expr)
        H.ParseFailed _ msg  -> parserFail msg
  
betweenBraces :: Parser String
betweenBraces = do
  between (char '{') (char '}') (concat <$> many insideBraces)
  where
    insideBraces = do
      ((\s -> '{' : s ++ "}") <$> betweenBraces) <|> ((: []) <$> satisfy (/= '}'))


identifier :: Parser String
identifier =
  try (ident <?> "identifier")
  where
    ident = do
      c  <- (letter <|> char '_' <|> char '$')
      cs <- many (alphaNum <|> char '_')
      return (c : cs)


stringLiteral :: Parser String
stringLiteral =
  (do
      str <- between (char '"')
                    (char '"' <?> "end of string")
                    (many stringChar)
      return . foldr (maybe id (:)) "" $ str) <?> "string literal"

stringChar :: Parser (Maybe Char)
stringChar =
  ( do
       c <- stringLetter
       return $ Just c) <|> stringEscape <?> "string character"

stringLetter :: Parser Char
stringLetter =
  satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))

stringEscape :: Parser (Maybe Char)
stringEscape =
  char '\\' *> ((escapeGap   *> return Nothing) <|>
                (escapeEmpty *> return Nothing) <|>
                (Just <$> escapeCode          ))
  where
    escapeEmpty = char '&'
    escapeGap   = many1 space >> (char '\\' <?> "end of string gap")
    escapeCode  = charEsc <|> charNum <|> charAscii <|> charControl <?> "escape code"
    
    charControl = char '^' *> ((\c -> toEnum (fromEnum c - fromEnum 'A')) <$> upper)
    charNum     =
      (toEnum . fromInteger) <$> (decimal <|> (char 'o' *> numberBuilder  8 octDigit)
                                          <|> (char 'x' *> numberBuilder 16 hexDigit))
    charEsc     =
      choice (map parseEsc escMap)
      where
        parseEsc (c, code) = char c *> pure code
    
    charAscii   =
      choice (map parseAscii asciiMap)
      where
        parseAscii (asc, code) = try (string asc *> pure code)
    
    escMap      = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'"
    asciiMap    = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)

    ascii2codes = [ "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", "EM", "FS", 
                    "GS", "RS", "US", "SP" ]
    ascii3codes = [ "NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", "DLE",
                    "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", "CAN", "SUB",
                    "ESC", "DEL" ]
    ascii2      = [ '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI', '\EM',
                    '\FS', '\GS', '\RS', '\US', '\SP' ]
    ascii3      = [ '\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
                    '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
                    '\CAN', '\SUB', '\ESC', '\DEL' ]


numberBuilder :: Integer -> Parser Char -> Parser Integer
numberBuilder base baseDigit = do
  digits <- many1 baseDigit
  let n = foldl (\x d -> base * x + toInteger (digitToInt d)) 0 digits
  seq n (return n)

decimal :: Parser Integer
decimal = numberBuilder 10 digit
  

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


mapQName :: H.QName -> Name
mapQName (H.Qual modu name) = Name (OccName $ strFromName name) (NameQ (ModName $ strFromModule modu))
mapQName (H.UnQual    name) = mkName (strFromName name)
mapQName (H.Special    con) = 
  case con of
    H.UnitCon          -> '()
    H.ListCon          -> '[]
    H.FunCon           -> mkName "(->)"
    H.TupleCon _ n     -> mkName ('(' : replicate n ',' ++ ")")
    H.Cons             -> '(:)
--    H.UnboxedSingleCon -> '(# #)
    H.UnboxedSingleCon -> error "No name for unboxed constructor"

mapName :: H.Name -> Name
mapName = mkName . strFromName

strFromName :: H.Name -> String
strFromName (H.Ident str) = str
strFromName (H.Symbol op) = op

strFromModule :: H.ModuleName -> String
strFromModule (H.ModuleName name) = name

mapDecl :: H.Decl -> [Dec]
mapDecl (H.TypeDecl _ name binds typ) = [TySynD (mapName name) (map mapTypeBind binds) (mapTypeToTH typ)]
mapDecl (H.TypeFamDecl _ name binds mKind) = [FamilyD TypeFam (mapName name) (map mapTypeBind binds) (maybe Nothing (Just . mapKind) mKind)]
mapDecl (H.DataDecl _ H.DataType ctx name binds qConDecl deriv) = [DataD (mapContext ctx) (mapName name) (map mapTypeBind binds)
                                                                         (map mapQCon qConDecl) (map (mapQName . fst) deriv)]
mapDecl (H.DataDecl _ H.NewType  ctx name binds qConDecl deriv) = [NewtypeD (mapContext ctx) (mapName name) (map mapTypeBind binds)
                                                                            (mapQCon (head qConDecl)) (map (mapQName . fst) deriv)]
mapDecl (H.GDataDecl _ _ _ _ _ _ _ _) = error "No support for GADTs in Template Haskell"
mapDecl (H.DataFamDecl _ _ name binds mKind) = [FamilyD DataFam (mapName name) (map mapTypeBind binds) (maybe Nothing (Just . mapKind) mKind)]
mapDecl (H.TypeInsDecl _ _ _) = error "No support for type instances"
mapDecl (H.DataInsDecl _ H.DataType _ _ _) = error "No support for data instances"
mapDecl (H.DataInsDecl _ H.NewType  _   _        _    ) = error "No support for data instances"
mapDecl (H.GDataInsDecl _ _ _ _ _ _) = error "No support for GADTs in Template Haskell"
mapDecl (H.ClassDecl _ ctx name binds funDeps classDecls) = [ClassD (mapContext ctx) (mapName name) (map mapTypeBind binds)
                                                                    (map mapFunDep funDeps) (map mapClassDecl classDecls)]
mapDecl (H.InstDecl _ ctx _ types instDecls) = [InstanceD (mapContext ctx) (mapTypeToTH (head types)) (map mapInstDecl instDecls)]
mapDecl (H.DerivDecl _ _ _ _) = error "No support for standalone deriving declarations in Template Haskell"
mapDecl (H.InfixDecl _ _ _ _) = error "No support for operator fixity declarations in Template Haskell"
mapDecl (H.DefaultDecl _ _) = error "No support for default declarations in Template Haskell"
mapDecl (H.SpliceDecl _ _) = error "Template Haskell brackets cannot be nested (without intervening splices)"
mapDecl (H.TypeSig _ names typ) = map (flip SigD (mapTypeToTH typ) . mapName) names
mapDecl (H.FunBind matches) = [FunD (matchName (head matches)) (map mapClause matches)]
mapDecl (H.PatBind _ pat _ rhs binds) = [ValD (mapPatToTH pat) (mapRhs rhs) (mapBinds binds)]
mapDecl (H.ForImp _ cc safe str name typ) = [ForeignD (ImportF (mapCC cc) (mapSafety safe) str (mapName name) (mapTypeToTH typ))]
mapDecl (H.ForExp _ cc str name typ) = [ForeignD (ExportF (mapCC cc) str (mapName name) (mapTypeToTH typ))]
mapDecl (H.RulePragmaDecl _ _) = error "No support for RULES pragma in Template Haskell"
mapDecl (H.DeprPragmaDecl _ _) = error "No support for DEPRECATED pragma in Template Haskell"
mapDecl (H.WarnPragmaDecl _ _) = error "No support for WARNING pragma in Template Haskell"
mapDecl (H.InlineSig _ _ _ name) = [PragmaD (InlineP (mapQName name) (InlineSpec True False Nothing))]
mapDecl (H.InlineConlikeSig _ _ _) = error "No current support for INLINE CONLIKE pragma"
mapDecl (H.SpecSig _ name types) = [PragmaD (SpecialiseP (mapQName name) (mapTypeToTH (head types)) Nothing)]
mapDecl (H.SpecInlineSig _ _ _ name types) = [PragmaD (SpecialiseP (mapQName name) (mapTypeToTH (head types)) (Just (InlineSpec True False Nothing)))]
mapDecl (H.InstSig _ _ _ _) = error "No support for SPECIALISE instance pragma in Template Haskell (I think...)"
mapDecl (H.AnnPragma _ _) = error "No support for ANN pragma in Template Haskell"

mapCC :: H.CallConv -> Callconv
mapCC (H.StdCall) = StdCall
mapCC (H.CCall  ) = CCall

mapSafety :: H.Safety -> Safety
mapSafety (H.PlayRisky ) = Unsafe
mapSafety (H.PlaySafe t) = if t then Threadsafe else Safe
                                                      
matchName :: H.Match -> Name
matchName (H.Match _ name _ _ _ _) = mapName name

mapClause :: H.Match -> Clause
mapClause (H.Match _ _ pats _ rhs binds) = Clause (map mapPatToTH pats) (mapRhs rhs) (mapBinds binds)

mapRhs :: H.Rhs -> Body
mapRhs (H.UnGuardedRhs     e) = NormalB (mapExpToTH e)
mapRhs (H.GuardedRhss guards) =
  GuardedB (map mapGRhs guards)
  where
    mapGRhs (H.GuardedRhs _ stmts e) = (PatG (map mapStmt stmts), mapExpToTH e)

  
mapInstDecl :: H.InstDecl -> Dec
mapInstDecl (H.InsDecl decl) = head (mapDecl decl)
mapInstDecl _                = error "Unsupported"

mapClassDecl :: H.ClassDecl -> Dec
mapClassDecl (H.ClsDecl decl) = head (mapDecl decl)
mapClassDecl _                = error "Unsupported"

mapFunDep :: H.FunDep -> FunDep
mapFunDep (H.FunDep xs ys) = FunDep (map mapName xs) (map mapName ys)

mapQCon :: H.QualConDecl -> Con
mapQCon (H.QualConDecl _ []    []  conDecl) = mapCon conDecl
mapQCon (H.QualConDecl _ binds ctx conDecl) = ForallC (map mapTypeBind binds) (mapContext ctx) (mapCon conDecl)

mapCon :: H.ConDecl -> Con
mapCon (H.ConDecl     name args) = NormalC (mapName name) (map mapBangType args)
mapCon (H.InfixConDecl x name y) = InfixC (mapBangType x) (mapName name) (mapBangType y)
mapCon (H.RecDecl   name fields) = RecC (mapName name) $ map (uncurry mapFieldDecl) $ concatMap (uncurry ((. repeat) . zip)) fields

mapFieldDecl :: H.Name -> H.BangType -> VarStrictType
mapFieldDecl name bType = let (strict, typ) = mapBangType bType
                          in (mapName name, strict, typ)

mapBangType :: H.BangType -> StrictType
mapBangType (H.BangedTy   t) = (IsStrict,  mapTypeToTH t)
mapBangType (H.UnBangedTy t) = (NotStrict, mapTypeToTH t)
mapBangType (H.UnpackedTy _) = error "No support for unboxed type (via UNPACK pragma) in Template Haskell"


mapExpToTH :: H.Exp -> Exp
mapExpToTH (H.Var             name) = VarE (mapQName name)
mapExpToTH (H.IPVar              _) = error "No implicit parameter support"
mapExpToTH (H.Con             name) = ConE (mapQName name)
mapExpToTH (H.Lit              lit) = LitE (mapLitToTH lit)
mapExpToTH (H.InfixApp      l op r) = InfixE (Just $ mapExpToTH l) (mapQOpToTH op) (Just $ mapExpToTH r)
mapExpToTH (H.App              l r) = (mapExpToTH l) `AppE` (mapExpToTH r)
mapExpToTH (H.NegApp             o) = AppE (VarE 'negate) (mapExpToTH o)
mapExpToTH (H.Lambda       _ pat e) = LamE (map mapPatToTH pat) (mapExpToTH e)
mapExpToTH (H.Let             bs e) = LetE (mapBinds bs) (mapExpToTH e)
mapExpToTH (H.If             e t f) = CondE (mapExpToTH e) (mapExpToTH t) (mapExpToTH f)
mapExpToTH (H.Case            e ms) = CaseE (mapExpToTH e) (map mapAlt ms)
mapExpToTH (H.Do                 s) = DoE (map mapStmt s)
mapExpToTH (H.MDo                _) = error "No support for mdo expressions"
mapExpToTH (H.Tuple             es) = TupE (map mapExpToTH es)
mapExpToTH (H.TupleSection       _) = error "Tuple sections currently not supported by template haskell"
mapExpToTH (H.List              es) = ListE (map mapExpToTH es)
mapExpToTH (H.Paren              e) = mapExpToTH e
mapExpToTH (H.LeftSection      e o) = InfixE (Just (mapExpToTH e)) (mapQOpToTH o) Nothing
mapExpToTH (H.RightSection     o e) = InfixE Nothing (mapQOpToTH o) (Just (mapExpToTH e))
mapExpToTH (H.RecConstr       n fs) = RecConE (mapQName n) (map mapFieldUpdate fs)
mapExpToTH (H.RecUpdate       e fs) = RecUpdE (mapExpToTH e) (map mapFieldUpdate fs)
mapExpToTH (H.EnumFrom           e) = ArithSeqE (FromR (mapExpToTH e))
mapExpToTH (H.EnumFromTo       x y) = ArithSeqE (FromToR (mapExpToTH x) (mapExpToTH y))
mapExpToTH (H.EnumFromThen     x y) = ArithSeqE (FromThenR (mapExpToTH x) (mapExpToTH y))
mapExpToTH (H.EnumFromThenTo x y z) = ArithSeqE (FromThenToR (mapExpToTH x) (mapExpToTH y) (mapExpToTH z))
mapExpToTH (H.ListComp        e qs) = CompE (map mapQualStmt qs ++ [NoBindS $ mapExpToTH e])
mapExpToTH (H.ParComp          _ _) = error "No support for parallel list comprehensions in Template Haskell"
mapExpToTH (H.ExpTypeSig     _ e t) = SigE (mapExpToTH e) (mapTypeToTH t)
mapExpToTH (H.VarQuote           _) = error "Template Haskell brackets cannot be nested (without intervening splices)"
mapExpToTH (H.TypQuote           _) = error "Template Haskell brackets cannot be nested (without intervening splices)"
mapExpToTH (H.BracketExp         _) = error "Template Haskell brackets cannot be nested (without intervening splices)"
mapExpToTH (H.SpliceExp          _) = error "Template Haskell brackets cannot be nested (without intervening splices)"
mapExpToTH (H.QuasiQuote       _ _) = error "Template Haskell brackets cannot be nested (without intervening splices)"
mapExpToTH (H.XTag       _ _ _ _ _) = error "No support for XML extension in Template Haskell"
mapExpToTH (H.XETag        _ _ _ _) = error "No support for XML extension in Template Haskell"
mapExpToTH (H.XPcdata            _) = error "No support for XML extension in Template Haskell"
mapExpToTH (H.XExpTag            _) = error "No support for XML extension in Template Haskell"
mapExpToTH (H.XChildTag        _ _) = error "No support for XML extension in Template Haskell"
mapExpToTH (H.CorePragma       _ _) = error "No support for pragmas in Template Haskell"
mapExpToTH (H.SCCPragma        _ _) = error "No support for pragmas in Template Haskell"
mapExpToTH (H.GenPragma    _ _ _ _) = error "No support for pragmas in Template Haskell"
mapExpToTH (H.Proc           _ _ _) = error "No support for arrows 'proc' in Template Haskell"
mapExpToTH (H.LeftArrApp       _ _) = error "No support for left arrow application in Template Haskell"
mapExpToTH (H.RightArrApp      _ _) = error "No support for right arrow application in Template Haskell"
mapExpToTH (H.LeftArrHighApp   _ _) = error "No support for higher-order left arrow application in Template Haskell"
mapExpToTH (H.RightArrHighApp  _ _) = error "No support for higher-order right arrow application in Template Haskell"


mapQualStmt :: H.QualStmt -> Stmt
mapQualStmt (H.QualStmt stmt) = mapStmt stmt
mapQualStmt _                 = error "No support for SQL-like generalized list comprehensions (not supported by Template Haskell)"

mapFieldUpdate :: H.FieldUpdate -> FieldExp
mapFieldUpdate (H.FieldUpdate n e) = (mapQName n, mapExpToTH e)
mapFieldUpdate (H.FieldPun      _) = error "No support for field puns in update expressions"
mapFieldUpdate (H.FieldWildcard  ) = error "No support for field wildcards in update expressions"

mapAlt :: H.Alt -> Match
mapAlt (H.Alt _ p g bs) = Match (mapPatToTH p) (mapGuard g) (mapBinds bs)

mapGuard :: H.GuardedAlts -> Body
mapGuard (H.UnGuardedAlt e) = NormalB (mapExpToTH e)
mapGuard (H.GuardedAlts gs) =
  GuardedB (map mapGAlt gs)
  where
    mapGAlt (H.GuardedAlt _ stmts e) = (PatG (map mapStmt stmts), mapExpToTH e)

mapStmt :: H.Stmt -> Stmt
mapStmt (H.Generator _ p e) = BindS (mapPatToTH p) (mapExpToTH e)
mapStmt (H.Qualifier     e) = NoBindS (mapExpToTH e)
mapStmt (H.LetStmt      bs) = LetS (mapBinds bs)
mapStmt (H.RecStmt      rs) = ParS [map mapStmt rs]

mapBinds :: H.Binds -> [Dec]
mapBinds (H.BDecls decls) = concatMap mapDecl decls
mapBinds (H.IPBinds    _) = error "No support for implicit parameter bindings"

mapQOpToTH :: H.QOp -> Exp
mapQOpToTH (H.QVarOp name) = VarE (mapQName name)
mapQOpToTH (H.QConOp name) = ConE (mapQName name)

{-
mapQOpToTHT :: H.QOp -> Type
mapQOpToTHT (H.QVarOp name) = VarT (mapQName name)
mapQOpToTHT (H.QConOp name) = ConT (mapQName name)
-}

mapPatToTH :: H.Pat -> Pat
mapPatToTH (H.PVar        name) = VarP (mapName name)
mapPatToTH (H.PLit         lit) = LitP (mapLitToTH lit)
mapPatToTH (H.PNeg           _) = error "What?! (http://trac.haskell.org/haskell-src-exts/ticket/209)"
mapPatToTH (H.PNPlusK      _ _) = error "No support for N+K patterns"
mapPatToTH (H.PInfixApp  l n r) = InfixP (mapPatToTH l) (mapQName n) (mapPatToTH r)
mapPatToTH (H.PApp         n p) = ConP (mapQName n) (map mapPatToTH p)
mapPatToTH (H.PTuple         p) = TupP (map mapPatToTH p)
mapPatToTH (H.PList          p) = ListP (map mapPatToTH p)
mapPatToTH (H.PParen         p) = mapPatToTH p
mapPatToTH (H.PRec        n pf) = RecP (mapQName n) (map mapPatFieldToTH pf)
mapPatToTH (H.PAsPat       n p) = AsP (mapName n) (mapPatToTH p)
mapPatToTH (H.PWildCard       ) = WildP
mapPatToTH (H.PIrrPat        p) = TildeP (mapPatToTH p)
mapPatToTH (H.PatTypeSig _ p t) = SigP (mapPatToTH p) (mapTypeToTH t)
mapPatToTH (H.PViewPat     _ _) = error "No support for view patterns"
mapPatToTH (H.PRPat          _) = error "I don't know what a PR pattern is"
mapPatToTH (H.PXTag  _ _ _ _ _) = error "No support for XML"
mapPatToTH (H.PXETag   _ _ _ _) = error "No support for XML"
mapPatToTH (H.PXPcdata       _) = error "No support for XML"
mapPatToTH (H.PXPatTag       _) = error "No support for XML"
mapPatToTH (H.PXRPats        _) = error "No support for XML"
mapPatToTH (H.PExplTypeArg _ _) = error "No support for explicit type arguments"
mapPatToTH (H.PQuasiQuote  _ _) = error "No support for quasi-quotation"
mapPatToTH (H.PBangPat       _) = error "No support for bang patterns"

mapTypeToTH :: H.Type -> Type
mapTypeToTH (H.TyForall vb ctx t) = ForallT (maybe [] (map mapTypeBind) vb) (mapContext ctx) (mapTypeToTH t)
mapTypeToTH (H.TyFun         l r) = AppT (AppT ArrowT (mapTypeToTH l)) (mapTypeToTH r)
mapTypeToTH (H.TyTuple      _ ts) = foldl AppT (TupleT (length ts)) (map mapTypeToTH ts)
mapTypeToTH (H.TyList          t) = AppT ListT (mapTypeToTH t)
mapTypeToTH (H.TyApp         l r) = AppT (mapTypeToTH l) (mapTypeToTH r)
mapTypeToTH (H.TyVar           v) = VarT (mapName v)
mapTypeToTH (H.TyCon           c) = ConT (mapQName c)
mapTypeToTH (H.TyParen         t) = mapTypeToTH t
mapTypeToTH (H.TyInfix    l op r) = AppT (AppT (ConT $ mapQName op) (mapTypeToTH l)) (mapTypeToTH r)
mapTypeToTH (H.TyKind        _ _) = error "No support for types with explicit type kinds"

mapTypeBind :: H.TyVarBind -> TyVarBndr
mapTypeBind (H.KindedVar n k) = KindedTV (mapName n) (mapKind k)
mapTypeBind (H.UnkindedVar n) = PlainTV (mapName n)

mapKind :: H.Kind -> Kind
mapKind (H.KindStar   ) = StarK
mapKind (H.KindBang   ) = error "No support for bang-kinds"
mapKind (H.KindFn  x y) = ArrowK (mapKind x) (mapKind y)
mapKind (H.KindParen k) = mapKind k
mapKind (H.KindVar   _) = error "No support for kind variables"

mapContext :: H.Context -> Cxt
mapContext =
  map mapAssert
  where
    mapAssert (H.ClassA  q ts) = ClassP (mapQName q) (map mapTypeToTH ts)
    mapAssert (H.InfixA x q y) = ClassP (mapQName q) [mapTypeToTH x, mapTypeToTH y]
    mapAssert (H.IParam   _ _) = error "No support for implicit parameter assertion"
    mapAssert (H.EqualP   x y) = EqualP (mapTypeToTH x) (mapTypeToTH y)

mapPatFieldToTH :: H.PatField -> FieldPat
mapPatFieldToTH (H.PFieldPat name pat) = (mapQName name, mapPatToTH pat)
mapPatFieldToTH (H.PFieldPun        _) = error "field puns not yet supported"
mapPatFieldToTH (H.PFieldWildcard    ) = (mkName "", WildP)

mapLitToTH :: H.Literal -> Lit
mapLitToTH (H.Char       c) = CharL       c
mapLitToTH (H.String     s) = StringL     s
mapLitToTH (H.Int        i) = IntegerL    i
mapLitToTH (H.Frac       r) = RationalL   r
mapLitToTH (H.PrimInt    i) = IntPrimL    i
mapLitToTH (H.PrimWord   w) = WordPrimL   w
mapLitToTH (H.PrimFloat  f) = FloatPrimL  f
mapLitToTH (H.PrimDouble d) = DoublePrimL d
mapLitToTH (H.PrimChar   c) = CharL       c
mapLitToTH (H.PrimString s) = StringPrimL s



-- Local Variables:
-- mode                  : Haskell
-- fill-column           : 120
-- default-justification : left
-- End:
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.