← Back to branch summary

~ubuntu-branches/debian/sid/c2hs/sid

« back to all changes in this revision

Viewing changes to c2hs/chs/CHS.hs

  • Committer: Bazaar Package Importer
  • Author(s): Arjan Oosting
  • Date: 2006-12-14 00:06:12 UTC
  • mfrom: (3.1.5 feisty)
  • Revision ID: james.westby@ubuntu.com-20061214000612-s7mds83cxqkgv1bj
Tags: 0.14.5-6
http://bugs.debian.org/402979
* debian/patches/09_replace-deprecated-withObject: Replace all
  occurrences of 'withObject' with 'with' as the deprecated 'withObject'
  was removed with GHC 6.6. (Closes: #402979)
* Set the urgency to medium as the above bug decreases c2hs usefulness
  with GHC 6.6 dramatically. 

Show diffs side-by-side

added added

removed removed

Lines of Context:
c2hs/chs/CHS.hs
3
3
--  Author : Manuel M T Chakravarty
4
4
--  Created: 16 August 99
5
5
--
 
6
--  Version $Revision: 1.27 $ from $Date: 2005/03/14 00:26:58 $
6
7
--
 
8
--  Copyright (c) [1999..2005] Manuel M T Chakravarty
7
9
--
8
10
--  This file is free software; you can redistribute it and/or modify
9
11
--  it under the terms of the GNU General Public License as published by
58
58
--            | `fun' [`pure'] [`unsafe'] idalias parms
59
59
--            | `get' apath
60
60
--            | `set' apath
61
 
--            | `pointer' ['*'] idalias ptrkind
 
61
--            | `pointer' ['*'] idalias ptrkind ['nocode']
62
62
--            | `class' [ident `=>'] ident ident
63
63
--  ctxt     -> [`lib' `=' string] [prefix]
64
64
--  idalias  -> ident [`as' (ident | `^')]
71
71
--            | apath `.' ident
72
72
--            | apath `->' ident
73
73
--  trans    -> `{' alias_1 `,' ... `,' alias_n `}'
 
74
--  alias    -> `underscoreToCase' | `upcaseFirstLetter' 
 
75
--            | `downcaseFirstLetter'
74
76
--            | ident `as' ident
75
77
--  ptrkind  -> [`foreign' | `stable'] ['newtype' | '->' ident]
76
78
--  
 
79
--  If `underscoreToCase', `upcaseFirstLetter', or `downcaseFirstLetter'
 
80
--  occurs in a translation table, it must be the first entry, or if two of
 
81
--  them occur the first two entries.
77
82
--
78
83
--  Remark: Optional Haskell names are normalised during structure tree
79
84
--          construction, ie, associations that associated a name with itself
86
88
--- TODO ----------------------------------------------------------------------
87
89
--
88
90
 
89
 
module CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..), CHSParm(..),
90
 
            CHSArg(..), CHSAccess(..), CHSAPath(..), CHSPtrType(..),
91
 
            loadCHS, dumpCHS, hssuffix, chssuffix, loadCHI, dumpCHI,
92
 
            chisuffix, showCHSParm)
 
91
module CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..),
 
92
            CHSChangeCase(..), CHSParm(..), CHSArg(..), CHSAccess(..),
 
93
            CHSAPath(..), CHSPtrType(..), 
 
94
            loadCHS, dumpCHS, hssuffix, chssuffix, loadCHI, dumpCHI, chisuffix,
 
95
            showCHSParm)
93
96
where 
94
97
 
95
98
-- standard libraries
194
197
                          CHSPtrType            -- Ptr, ForeignPtr or StablePtr
195
198
                          Bool                  -- create new type?
196
199
                          (Maybe Ident)         -- Haskell type pointed to
 
200
                          Bool                  -- emit type decl?
197
201
                          Position
198
202
             | CHSClass   (Maybe Ident)         -- superclass
199
203
                          Ident                 -- class name
209
213
  posOf (CHSCall    _ _ _ _       pos) = pos
210
214
  posOf (CHSFun     _ _ _ _ _ _ _ pos) = pos
211
215
  posOf (CHSField   _ _           pos) = pos
212
 
  posOf (CHSPointer _ _ _ _ _ _   pos) = pos
 
216
  posOf (CHSPointer _ _ _ _ _ _ _ pos) = pos
213
217
  posOf (CHSClass   _ _ _         pos) = pos
214
218
 
215
219
-- two hooks are equal if they have the same Haskell name and reference the
233
237
    oalias1 == oalias2 && ide1 == ide2
234
238
  (CHSField acc1 path1         _) == (CHSField acc2 path2         _) =    
235
239
    acc1 == acc2 && path1 == path2
236
 
  (CHSPointer _ ide1 oalias1 _ _ _ _) 
237
 
                                  == (CHSPointer _ ide2 oalias2 _ _ _ _) =
 
240
  (CHSPointer _ ide1 oalias1 _ _ _ _ _) 
 
241
                                  == (CHSPointer _ ide2 oalias2 _ _ _ _ _) =
238
242
    ide1 == ide2 && oalias1 == oalias2
239
243
  (CHSClass _ ide1 _           _) == (CHSClass _ ide2 _           _) =
240
244
    ide1 == ide2
243
247
-- translation table (EXPORTED)
244
248
--
245
249
data CHSTrans = CHSTrans Bool                   -- underscore to case?
 
250
                         CHSChangeCase          -- upcase or downcase?
246
251
                         [(Ident, Ident)]       -- alias list
247
252
 
 
253
data CHSChangeCase = CHSSameCase 
 
254
                   | CHSUpCase 
 
255
                   | CHSDownCase
 
256
                   deriving Eq
 
257
 
248
258
-- marshalling descriptor for function hooks (EXPORTED)
249
259
--
250
260
-- * a marshaller consists of a function name and flag indicating whether it
374
384
  where
375
385
    contents version kind = 
376
386
      "-- GENERATED by " ++ version ++ " " ++ kind ++ "\n\
377
 
      \-- ** Edit the orignal .chs file instead!\n\n"
 
387
      \-- Edit the ORIGNAL .chs file instead!\n\n"
378
388
      ++ showCHSModule mod pureHaskell
379
389
 
380
390
-- to keep track of the current state of the line emission automaton
408
418
        nextState        = if generated then Wait else NoLine
409
419
      in
410
420
        (if emitNow then
411
 
           showString ("{-# LINE " ++ show (line `max` 0) ++ " " ++ show fname 
412
 
                       ++ " #-}\n")
 
421
           showString ("\n{-# LINE " ++ show (line `max` 0) ++ " " ++ 
 
422
                       show fname ++ " #-}")
413
423
         else id)
414
424
      . showString s
415
425
      . showFrags pureHs nextState frags
421
431
    showFrags False  _     (CHSCPP  s    _     : frags) =   
422
432
        showChar '#'
423
433
      . showString s
424
 
      . showChar '\n'
 
434
--      . showChar '\n'
425
435
      . showFrags False Emit frags
426
436
    showFrags False  _     (CHSC    s    _     : frags) =
427
 
        showString "\n#c\n"
 
437
        showString "\n#c"
428
438
      . showString s
429
 
      . showString "\n#endc\n"
 
439
      . showString "\n#endc"
430
440
      . showFrags False Emit frags
431
441
    showFrags False  _     (CHSCond _    _     : frags) =
432
442
      interr "showCHSFrag: Cannot print `CHSCond'!"
481
491
       CHSGet -> showString "get "
482
492
       CHSSet -> showString "set ")
483
493
  . showCHSAPath path
484
 
showCHSHook (CHSPointer star ide oalias ptrType isNewtype oRefType _) =
 
494
showCHSHook (CHSPointer star ide oalias ptrType isNewtype oRefType emit _) =
485
495
    showString "pointer "
486
496
  . (if star then showString "*" else showString "")
487
497
  . showIdAlias ide oalias
493
503
       (True , _       ) -> showString " newtype" 
494
504
       (False, Just ide) -> showString " -> " . showCHSIdent ide
495
505
       (False, Nothing ) -> showString "")
 
506
  . (case emit of
 
507
       True  -> showString "" 
 
508
       False -> showString " nocode")
496
509
showCHSHook (CHSClass oclassIde classIde typeIde _) =   
497
510
    showString "class "
498
511
  . (case oclassIde of
536
549
    --
537
550
    showHsVerb str = showChar '`' . showString str . showChar '\''
538
551
 
539
 
showCHSTrans                          :: CHSTrans -> ShowS
540
 
showCHSTrans (CHSTrans _2Case assocs)  =   
 
552
showCHSTrans :: CHSTrans -> ShowS
 
553
showCHSTrans (CHSTrans _2Case chgCase assocs)  =   
541
554
    showString "{"
542
555
  . (if _2Case then showString ("underscoreToCase" ++ maybeComma) else id)
 
556
  . showCHSChangeCase chgCase
543
557
  . foldr (.) id (intersperse (showString ", ") (map showAssoc assocs))
544
558
  . showString "}"
545
559
  where
550
564
      . showString " as "
551
565
      . showCHSIdent ide2
552
566
 
 
567
showCHSChangeCase :: CHSChangeCase -> ShowS
 
568
showCHSChangeCase CHSSameCase = id
 
569
showCHSChangeCase CHSUpCase   = showString "upcaseFirstLetter"
 
570
showCHSChangeCase CHSDownCase = showString "downcaseFirstLetter"
 
571
 
553
572
showCHSAPath :: CHSAPath -> ShowS
554
573
showCHSAPath (CHSRoot ide) =
555
574
  showCHSIdent ide
755
774
parseImport pos toks = do
756
775
  (qual, modid, toks') <- 
757
776
    case toks of
758
 
      CHSTokIdent _ ide                :toks -> return (False, ide, toks)
759
 
      CHSTokQualif _: CHSTokIdent _ ide:toks -> return (True , ide, toks)
 
777
      CHSTokIdent _ ide                :toks ->
 
778
        let (ide', toks') = rebuildModuleId ide toks
 
779
         in return (False, ide', toks')
 
780
      CHSTokQualif _: CHSTokIdent _ ide:toks ->
 
781
        let (ide', toks') = rebuildModuleId ide toks
 
782
         in return (True , ide', toks')
760
783
      _                                      -> syntaxError toks
761
 
  chi <- loadCHI . identToLexeme $ modid
 
784
  chi <- loadCHI . moduleNameToFileName . identToLexeme $ modid
762
785
  toks'' <- parseEndHook toks'
763
786
  frags <- parseFrags toks''
764
787
  return $ CHSHook (CHSImport qual modid chi pos) : frags
765
788
 
 
789
-- Qualified module names do not get lexed as a single token so we need to
 
790
-- reconstruct it from a sequence of identifer and dot tokens.
 
791
--
 
792
rebuildModuleId ide (CHSTokDot _ : CHSTokIdent _ ide' : toks) = 
 
793
  let catIdent ide ide' = onlyPosIdent (posOf ide)  --FIXME: unpleasent hack
 
794
                            (identToLexeme ide ++ '.' : identToLexeme ide')
 
795
   in rebuildModuleId (catIdent ide ide') toks
 
796
rebuildModuleId ide                                     toks  = (ide, toks)
 
797
 
 
798
moduleNameToFileName :: String -> FilePath
 
799
moduleNameToFileName = map dotToSlash
 
800
  where dotToSlash '.' = '/'
 
801
        dotToSlash c   = c
 
802
 
766
803
parseContext          :: Position -> [CHSToken] -> CST s [CHSFrag]
767
804
parseContext pos toks  = do
768
805
                           (olib    , toks'' ) <- parseOptLib          toks
916
953
        CHSTokNewtype _                  :toks' -> (True , Nothing , toks' )
917
954
        CHSTokArrow   _:CHSTokIdent _ ide:toks' -> (False, Just ide, toks' )
918
955
        _                                       -> (False, Nothing , toks'3)
919
 
    toks'5                        <- parseEndHook toks'4
920
 
    frags                         <- parseFrags   toks'5
 
956
    let 
 
957
     (emit, toks'5) =
 
958
      case toks'4 of
 
959
        CHSTokNocode _                  :toks' -> (False, toks' )
 
960
        _                                      -> (True , toks'4 )
 
961
    toks'6                        <- parseEndHook toks'5
 
962
    frags                         <- parseFrags   toks'6
921
963
    return $ 
922
964
      CHSHook 
923
 
       (CHSPointer isStar ide (norm ide oalias) ptrType isNewtype oRefType pos)
 
965
       (CHSPointer 
 
966
         isStar ide (norm ide oalias) ptrType isNewtype oRefType emit pos)
924
967
       : frags
925
968
  where
926
969
    parsePtrType :: [CHSToken] -> CST s (CHSPtrType, [CHSToken])
974
1017
parseOptPrefix _     toks                  = return (Nothing, toks)
975
1018
 
976
1019
-- first argument is the identifier that is to be used when `^' is given and
 
1020
-- the second indicates whether the first character has to be upper case
977
1021
--
978
1022
parseOptAs :: Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
979
1023
parseOptAs _   _     (CHSTokAs _:CHSTokIdent _ ide:toks) = 
1041
1084
parseTrans :: [CHSToken] -> CST s (CHSTrans, [CHSToken])
1042
1085
parseTrans (CHSTokLBrace _:toks) =
1043
1086
  do
1044
 
    (_2Case, toks' ) <- parse_2Case toks
 
1087
    (_2Case, chgCase, toks' ) <- parse_2CaseAndChange toks
1045
1088
    case toks' of
1046
 
      (CHSTokRBrace _:toks'') -> return (CHSTrans _2Case [], toks'')
 
1089
      (CHSTokRBrace _:toks'') -> return (CHSTrans _2Case chgCase [], toks'')
1047
1090
      _                       ->
1048
1091
        do
1049
1092
          -- if there was no `underscoreToCase', we add a comma token to meet
1050
1093
          -- the invariant of `parseTranss'
1051
1094
          --
1052
 
          (transs, toks'') <- if _2Case 
 
1095
          (transs, toks'') <- if (_2Case || chgCase /= CHSSameCase)
1053
1096
                              then parseTranss toks'
1054
1097
                              else parseTranss (CHSTokComma nopos:toks')
1055
 
          return (CHSTrans _2Case transs, toks'')
 
1098
          return (CHSTrans _2Case chgCase transs, toks'')
1056
1099
  where
1057
 
    parse_2Case (CHSTok_2Case _:toks) = return (True, toks)
1058
 
    parse_2Case toks                  = return (False, toks)
 
1100
    parse_2CaseAndChange (CHSTok_2Case _:CHSTokComma _:CHSTokUpper _:toks) = 
 
1101
      return (True, CHSUpCase, toks)
 
1102
    parse_2CaseAndChange (CHSTok_2Case _:CHSTokComma _:CHSTokDown _ :toks) = 
 
1103
      return (True, CHSDownCase, toks)
 
1104
    parse_2CaseAndChange (CHSTok_2Case _                            :toks) = 
 
1105
      return (True, CHSSameCase, toks)
 
1106
    parse_2CaseAndChange (CHSTokUpper _:CHSTokComma _:CHSTok_2Case _:toks) = 
 
1107
      return (True, CHSUpCase, toks)
 
1108
    parse_2CaseAndChange (CHSTokUpper _                             :toks) = 
 
1109
      return (False, CHSUpCase, toks)
 
1110
    parse_2CaseAndChange (CHSTokDown  _:CHSTokComma _:CHSTok_2Case _:toks) = 
 
1111
      return (True, CHSDownCase, toks)
 
1112
    parse_2CaseAndChange (CHSTokDown  _                             :toks) = 
 
1113
      return (False, CHSDownCase, toks)
 
1114
    parse_2CaseAndChange toks                                              = 
 
1115
      return (False, CHSSameCase, toks)
1059
1116
    --
1060
1117
    parseTranss (CHSTokRBrace _:toks) = return ([], toks)
1061
1118
    parseTranss (CHSTokComma  _:toks) = do