Teo Camarasu pushed to branch wip/abstract-q at Glasgow Haskell Compiler / GHC

Commits:

3 changed files:

Changes:

  • compiler/GHC/Tc/Gen/Splice.hs
    ... ... @@ -1139,6 +1139,7 @@ convertAnnotationWrapper fhv = do
    1139 1139
     ************************************************************************
    
    1140 1140
     -}
    
    1141 1141
     
    
    1142
    +-- TODO: rename
    
    1142 1143
     runQuasi :: TH.Q a -> TcM a
    
    1143 1144
     runQuasi (TH.Q act) = unliftIOEnv $ \runInIO -> liftIO $ act (metaHandlersTcM runInIO)
    
    1144 1145
     
    
    ... ... @@ -1467,7 +1468,7 @@ when showing an error message.
    1467 1468
     To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
    
    1468 1469
     -}
    
    1469 1470
     
    
    1470
    -report :: Bool -> [Char] -> TcM ()
    
    1471
    +report :: Bool -> String -> TcM ()
    
    1471 1472
     report True msg  = seqList msg $ addErr        $ TcRnTHError $ ReportCustomQuasiError True  msg
    
    1472 1473
     report False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg
    
    1473 1474
     
    
    ... ... @@ -1559,7 +1560,8 @@ location = do { m <- getModule
    1559 1560
     
    
    1560 1561
     metaHandlersTcM :: (forall x. TcM x -> IO x) -> TH.MetaHandlers IO
    
    1561 1562
     metaHandlersTcM runInIO = TH.MetaHandlers {
    
    1562
    -    mFail = \s -> runInIO $ fail s
    
    1563
    +    -- We are careful to use the TcM instance not the one for IO, since that would lead to a different error.
    
    1564
    +    mFail = \s -> runInIO $ fail @TcM s
    
    1563 1565
         , mNewName = \s -> runInIO $ do { u <- newUnique
    
    1564 1566
                           ; let i = toInteger (getKey u)
    
    1565 1567
                           ; return (TH.mkNameU s i) }
    
    ... ... @@ -1578,16 +1580,17 @@ metaHandlersTcM runInIO = TH.MetaHandlers {
    1578 1580
         , mReifyRoles       = runInIO . reifyRoles
    
    1579 1581
         , mReifyAnnotations = runInIO . reifyAnnotations
    
    1580 1582
         , mReifyModule      = runInIO . reifyModule
    
    1581
    -    , mReifyConStrictness = \nm -> runInIO $ do { nm' <- lookupThName nm
    
    1583
    +    , mReifyConStrictness = \nm -> runInIO $ do
    
    1584
    +                                      { nm' <- lookupThName nm
    
    1582 1585
                                           ; dc  <- tcLookupDataCon nm'
    
    1583 1586
                                           ; let bangs = dataConImplBangs dc
    
    1584 1587
                                           ; return (map reifyDecidedStrictness bangs) }
    
    1585 1588
     
    
    1586
    -    --       -- For qRecover, discard error messages if
    
    1587
    -    --       -- the recovery action is chosen.  Otherwise
    
    1588
    -    --       -- we'll only fail higher up.
    
    1589
    -    --       -- NB: extremely subtle!!! TODO: write up note
    
    1590
    -    --       -- tryTcDiscardingErrs manipulates the reader env so we need to be careful we don't sneak in the outside env
    
    1589
    +          -- For qRecover, discard error messages if
    
    1590
    +          -- the recovery action is chosen.  Otherwise
    
    1591
    +          -- we'll only fail higher up.
    
    1592
    +          -- NB: extremely subtle!!! TODO: write up note
    
    1593
    +          -- tryTcDiscardingErrs manipulates the reader env so we need to be careful we don't sneak in the outside env
    
    1591 1594
         , mRecover = \recover main -> runInIO $ tryTcDiscardingErrs (runQuasi recover) (runQuasi main)
    
    1592 1595
     
    
    1593 1596
         , mGetPackageRoot = runInIO $ do
    

  • libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
    ... ... @@ -52,175 +52,6 @@ import GHC.Internal.ForeignSrcLang
    52 52
     import GHC.Internal.LanguageExtensions
    
    53 53
     import GHC.Internal.TH.Syntax
    
    54 54
     
    
    55
    ------------------------------------------------------
    
    56
    ---
    
    57
    ---              The Quasi class
    
    58
    ---
    
    59
    ------------------------------------------------------
    
    60
    -
    
    61
    -class (MonadIO m, MonadFail m) => Quasi m where
    
    62
    -  qRunQ :: Q a -> m a
    
    63
    -  -- | Fresh names. See 'newName'.
    
    64
    -  qNewName :: String -> m Name
    
    65
    -
    
    66
    -  ------- Error reporting and recovery -------
    
    67
    -  -- | Report an error (True) or warning (False)
    
    68
    -  -- ...but carry on; use 'fail' to stop. See 'report'.
    
    69
    -  qReport  :: Bool -> String -> m ()
    
    70
    -
    
    71
    -  -- | See 'recover'.
    
    72
    -  qRecover :: m a -- ^ the error handler
    
    73
    -           -> m a -- ^ action which may fail
    
    74
    -           -> m a -- ^ Recover from the monadic 'fail'
    
    75
    -
    
    76
    -  ------- Inspect the type-checker's environment -------
    
    77
    -  -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
    
    78
    -  qLookupName :: Bool -> String -> m (Maybe Name)
    
    79
    -  -- | See 'reify'.
    
    80
    -  qReify          :: Name -> m Info
    
    81
    -  -- | See 'reifyFixity'.
    
    82
    -  qReifyFixity    :: Name -> m (Maybe Fixity)
    
    83
    -  -- | See 'reifyType'.
    
    84
    -  qReifyType      :: Name -> m Type
    
    85
    -  -- | Is (n tys) an instance? Returns list of matching instance Decs (with
    
    86
    -  -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
    
    87
    -  qReifyInstances :: Name -> [Type] -> m [Dec]
    
    88
    -  -- | See 'reifyRoles'.
    
    89
    -  qReifyRoles         :: Name -> m [Role]
    
    90
    -  -- | See 'reifyAnnotations'.
    
    91
    -  qReifyAnnotations   :: Data a => AnnLookup -> m [a]
    
    92
    -  -- | See 'reifyModule'.
    
    93
    -  qReifyModule        :: Module -> m ModuleInfo
    
    94
    -  -- | See 'reifyConStrictness'.
    
    95
    -  qReifyConStrictness :: Name -> m [DecidedStrictness]
    
    96
    -
    
    97
    -  -- | See 'location'.
    
    98
    -  qLocation :: m Loc
    
    99
    -
    
    100
    -  -- | Input/output (dangerous). See 'runIO'.
    
    101
    -  qRunIO :: IO a -> m a
    
    102
    -  qRunIO = liftIO
    
    103
    -  -- | See 'getPackageRoot'.
    
    104
    -  qGetPackageRoot :: m FilePath
    
    105
    -
    
    106
    -  -- | See 'addDependentFile'.
    
    107
    -  qAddDependentFile :: FilePath -> m ()
    
    108
    -
    
    109
    -  -- | See 'addDependentDirectory'.
    
    110
    -  qAddDependentDirectory :: FilePath -> m ()
    
    111
    -
    
    112
    -  -- | See 'addTempFile'.
    
    113
    -  qAddTempFile :: String -> m FilePath
    
    114
    -
    
    115
    -  -- | See 'addTopDecls'.
    
    116
    -  qAddTopDecls :: [Dec] -> m ()
    
    117
    -
    
    118
    -  -- | See 'addForeignFilePath'.
    
    119
    -  qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
    
    120
    -
    
    121
    -  -- | See 'addModFinalizer'.
    
    122
    -  qAddModFinalizer :: Q () -> m ()
    
    123
    -
    
    124
    -  -- | See 'addCorePlugin'.
    
    125
    -  qAddCorePlugin :: String -> m ()
    
    126
    -
    
    127
    -  -- | See 'getQ'.
    
    128
    -  qGetQ :: Typeable a => m (Maybe a)
    
    129
    -
    
    130
    -  -- | See 'putQ'.
    
    131
    -  qPutQ :: Typeable a => a -> m ()
    
    132
    -
    
    133
    -  -- | See 'isExtEnabled'.
    
    134
    -  qIsExtEnabled :: Extension -> m Bool
    
    135
    -  -- | See 'extsEnabled'.
    
    136
    -  qExtsEnabled :: m [Extension]
    
    137
    -
    
    138
    -  -- | See 'putDoc'.
    
    139
    -  qPutDoc :: DocLoc -> String -> m ()
    
    140
    -  -- | See 'getDoc'.
    
    141
    -  qGetDoc :: DocLoc -> m (Maybe String)
    
    142
    -
    
    143
    ------------------------------------------------------
    
    144
    ---      The IO instance of Quasi
    
    145
    ------------------------------------------------------
    
    146
    -
    
    147
    ---  | This instance is used only when running a Q
    
    148
    ---  computation in the IO monad, usually just to
    
    149
    ---  print the result.  There is no interesting
    
    150
    ---  type environment, so reification isn't going to
    
    151
    ---  work.
    
    152
    -instance Quasi IO where
    
    153
    -  qRunQ (Q m) = m metaHandlersIO
    
    154
    -  qNewName = newNameIO
    
    155
    -
    
    156
    -  qReport True  msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
    
    157
    -  qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
    
    158
    -
    
    159
    -  qLookupName _ _       = badIO "lookupName"
    
    160
    -  qReify _              = badIO "reify"
    
    161
    -  qReifyFixity _        = badIO "reifyFixity"
    
    162
    -  qReifyType _          = badIO "reifyFixity"
    
    163
    -  qReifyInstances _ _   = badIO "reifyInstances"
    
    164
    -  qReifyRoles _         = badIO "reifyRoles"
    
    165
    -  qReifyAnnotations _   = badIO "reifyAnnotations"
    
    166
    -  qReifyModule _        = badIO "reifyModule"
    
    167
    -  qReifyConStrictness _ = badIO "reifyConStrictness"
    
    168
    -  qLocation             = badIO "currentLocation"
    
    169
    -  qRecover _ _          = badIO "recover" -- Maybe we could fix this?
    
    170
    -  qGetPackageRoot       = badIO "getProjectRoot"
    
    171
    -  qAddDependentFile _   = badIO "addDependentFile"
    
    172
    -  qAddTempFile _        = badIO "addTempFile"
    
    173
    -  qAddTopDecls _        = badIO "addTopDecls"
    
    174
    -  qAddForeignFilePath _ _ = badIO "addForeignFilePath"
    
    175
    -  qAddModFinalizer _    = badIO "addModFinalizer"
    
    176
    -  qAddCorePlugin _      = badIO "addCorePlugin"
    
    177
    -  qGetQ                 = badIO "getQ"
    
    178
    -  qPutQ _               = badIO "putQ"
    
    179
    -  qIsExtEnabled _       = badIO "isExtEnabled"
    
    180
    -  qExtsEnabled          = badIO "extsEnabled"
    
    181
    -  qPutDoc _ _           = badIO "putDoc"
    
    182
    -  qGetDoc _             = badIO "getDoc"
    
    183
    -  qAddDependentDirectory _ = badIO "AddDependentDirectory"
    
    184
    -
    
    185
    -metaHandlersIO :: MetaHandlers IO
    
    186
    -metaHandlersIO  = MetaHandlers {
    
    187
    -    mFail = fail
    
    188
    -  , mNewName = newNameIO
    
    189
    -  , mReport = \b msg ->
    
    190
    -     if b then
    
    191
    -       hPutStrLn stderr ("Template Haskell error: " ++ msg)
    
    192
    -     else
    
    193
    -       hPutStrLn stderr ("Template Haskell error: " ++ msg) -- TODO: should this be different from above?
    
    194
    -  , mLookupName           = \ _ _ -> badIO "lookupName"
    
    195
    -  , mReify                = \_ -> badIO "reify"
    
    196
    -  , mReifyFixity          = \_ -> badIO "reifyFixity"
    
    197
    -  , mReifyType            = \_ -> badIO "reifyFixity"
    
    198
    -  , mReifyInstances       = \_ _ -> badIO "reifyInstances"
    
    199
    -  , mReifyRoles           = \_ -> badIO "reifyRoles"
    
    200
    -  , mReifyAnnotations     = \_ -> badIO "reifyAnnotations"
    
    201
    -  , mReifyModule          = \_ -> badIO "reifyModule"
    
    202
    -  , mReifyConStrictness   = \_ -> badIO "reifyConStrictness"
    
    203
    -  , mLocation             = badIO "currentLocation"
    
    204
    -  , mRecover              = \_ _ -> badIO "recover" -- Maybe we could fix this?
    
    205
    -  , mGetPackageRoot       = badIO "getProjectRoot"
    
    206
    -  , mAddDependentFile     = \_ -> badIO "addDependentFile"
    
    207
    -  , mAddTempFile          = \_ -> badIO "addTempFile"
    
    208
    -  , mAddTopDecls          = \_ -> badIO "addTopDecls"
    
    209
    -  , mAddForeignFilePath   = \_ _ -> badIO "addForeignFilePath"
    
    210
    -  , mAddModFinalizer      = \_ -> badIO "addModFinalizer"
    
    211
    -  , mAddCorePlugin        = \_ -> badIO "addCorePlugin"
    
    212
    -  , mGetQ                 = badIO "getQ"
    
    213
    -  , mPutQ                 = \_ -> badIO "putQ"
    
    214
    -  , mIsExtEnabled         = \_ -> badIO "isExtEnabled"
    
    215
    -  , mExtsEnabled          = badIO "extsEnabled"
    
    216
    -  , mPutDoc               = \_ _ -> badIO "putDoc"
    
    217
    -  , mGetDoc               = \_ -> badIO "getDoc"
    
    218
    -  , mAddDependentDirectory = \_ -> badIO "AddDependentDirectory"
    
    219
    -  }
    
    220
    -
    
    221
    -instance Quote IO where
    
    222
    -  newName = newNameIO
    
    223
    -
    
    224 55
     data MetaHandlers m = MetaHandlers {
    
    225 56
         mFail :: forall a. String -> m a
    
    226 57
         -- | Fresh names. See 'newName'.
    
    ... ... @@ -301,15 +132,51 @@ data MetaHandlers m = MetaHandlers {
    301 132
         , mGetDoc :: DocLoc -> m (Maybe String)
    
    302 133
       }
    
    303 134
     
    
    135
    +metaHandlersIO :: MetaHandlers IO
    
    136
    +metaHandlersIO  = MetaHandlers {
    
    137
    +    mFail = fail
    
    138
    +  , mNewName = newNameIO
    
    139
    +  , mReport = \b msg ->
    
    140
    +     if b then
    
    141
    +       hPutStrLn stderr ("Template Haskell error: " ++ msg)
    
    142
    +     else
    
    143
    +       hPutStrLn stderr ("Template Haskell error: " ++ msg) -- TODO: should this be different from above?
    
    144
    +  , mLookupName           = \ _ _ -> badIO "lookupName"
    
    145
    +  , mReify                = \_ -> badIO "reify"
    
    146
    +  , mReifyFixity          = \_ -> badIO "reifyFixity"
    
    147
    +  , mReifyType            = \_ -> badIO "reifyFixity"
    
    148
    +  , mReifyInstances       = \_ _ -> badIO "reifyInstances"
    
    149
    +  , mReifyRoles           = \_ -> badIO "reifyRoles"
    
    150
    +  , mReifyAnnotations     = \_ -> badIO "reifyAnnotations"
    
    151
    +  , mReifyModule          = \_ -> badIO "reifyModule"
    
    152
    +  , mReifyConStrictness   = \_ -> badIO "reifyConStrictness"
    
    153
    +  , mLocation             = badIO "currentLocation"
    
    154
    +  , mRecover              = \_ _ -> badIO "recover" -- Maybe we could fix this?
    
    155
    +  , mGetPackageRoot       = badIO "getProjectRoot"
    
    156
    +  , mAddDependentFile     = \_ -> badIO "addDependentFile"
    
    157
    +  , mAddTempFile          = \_ -> badIO "addTempFile"
    
    158
    +  , mAddTopDecls          = \_ -> badIO "addTopDecls"
    
    159
    +  , mAddForeignFilePath   = \_ _ -> badIO "addForeignFilePath"
    
    160
    +  , mAddModFinalizer      = \_ -> badIO "addModFinalizer"
    
    161
    +  , mAddCorePlugin        = \_ -> badIO "addCorePlugin"
    
    162
    +  , mGetQ                 = badIO "getQ"
    
    163
    +  , mPutQ                 = \_ -> badIO "putQ"
    
    164
    +  , mIsExtEnabled         = \_ -> badIO "isExtEnabled"
    
    165
    +  , mExtsEnabled          = badIO "extsEnabled"
    
    166
    +  , mPutDoc               = \_ _ -> badIO "putDoc"
    
    167
    +  , mGetDoc               = \_ -> badIO "getDoc"
    
    168
    +  , mAddDependentDirectory = \_ -> badIO "AddDependentDirectory"
    
    169
    +  }
    
    170
    +
    
    171
    +instance Quote IO where
    
    172
    +  newName = newNameIO
    
    173
    +
    
    174
    +
    
    304 175
     
    
    305 176
     newNameIO :: String -> IO Name
    
    306 177
     newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x))
    
    307 178
                      ; pure (mkNameU s n) }
    
    308 179
     
    
    309
    -badIO :: String -> IO a
    
    310
    -badIO op = do   { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
    
    311
    -                ; fail "Template Haskell failure" }
    
    312
    -
    
    313 180
     -- Global variable to generate unique symbols
    
    314 181
     counter :: IORef Uniq
    
    315 182
     {-# NOINLINE counter #-}
    
    ... ... @@ -430,14 +297,17 @@ class Monad m => Quote m where
    430 297
       -}
    
    431 298
       newName :: String -> m Name
    
    432 299
     
    
    300
    +-- | Utility function for lifting a 0-ary method of 'MetaHandlers' into 'Q'
    
    433 301
     runHandler :: (forall m. MetaHandlers m -> m a) -> Q a
    
    434
    -runHandler op = Q $ \h -> (op h)
    
    302
    +runHandler op = Q $ \h -> op h
    
    435 303
     
    
    304
    +-- | Utility function for lifting a 1-ary method of 'MetaHandlers' into 'Q'
    
    436 305
     runHandler1 :: (forall m. MetaHandlers m -> a -> m b) -> a -> Q b
    
    437
    -runHandler1 op = \x -> Q $ \h -> (op h x)
    
    306
    +runHandler1 op = \x -> Q $ \h -> op h x
    
    438 307
     
    
    308
    +-- | Utility function for lifting a 2-ary method of 'MetaHandlers' into 'Q'
    
    439 309
     runHandler2 :: (forall m. MetaHandlers m -> a -> b -> m c) -> a -> b -> Q c
    
    440
    -runHandler2 op = \x y -> Q $ \h -> (op h x y)
    
    310
    +runHandler2 op = \x y -> Q $ \h -> op h x y
    
    441 311
     
    
    442 312
     instance Quote Q where
    
    443 313
       newName = runHandler1 mNewName
    
    ... ... @@ -658,15 +528,15 @@ recover rec main = Q $ \h -> mRecover h rec main
    658 528
     -- We don't export lookupName; the Bool isn't a great API
    
    659 529
     -- Instead we export lookupTypeName, lookupValueName
    
    660 530
     lookupName :: Bool -> String -> Q (Maybe Name)
    
    661
    -lookupName ns s = runHandler2 mLookupName ns s
    
    531
    +lookupName = runHandler2 mLookupName
    
    662 532
     
    
    663 533
     -- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
    
    664 534
     lookupTypeName :: String -> Q (Maybe Name)
    
    665
    -lookupTypeName  s = runHandler2 mLookupName True s
    
    535
    +lookupTypeName = runHandler2 mLookupName True
    
    666 536
     
    
    667 537
     -- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
    
    668 538
     lookupValueName :: String -> Q (Maybe Name)
    
    669
    -lookupValueName s = runHandler2 mLookupName False s
    
    539
    +lookupValueName = runHandler2 mLookupName False
    
    670 540
     
    
    671 541
     {-
    
    672 542
     Note [Name lookup]
    
    ... ... @@ -850,7 +720,7 @@ has some discussion around this.
    850 720
     
    
    851 721
     -}
    
    852 722
     reifyInstances :: Name -> [Type] -> Q [InstanceDec]
    
    853
    -reifyInstances cls tys = runHandler2 mReifyInstances cls tys
    
    723
    +reifyInstances = runHandler2 mReifyInstances
    
    854 724
     
    
    855 725
     {- | @reifyRoles nm@ returns the list of roles associated with the parameters
    
    856 726
     (both visible and invisible) of
    
    ... ... @@ -869,20 +739,20 @@ and @reifyRoles Proxy@, we will get @['NominalR', 'PhantomR']@. The 'NominalR' i
    869 739
     the role of the invisible @k@ parameter. Kind parameters are always nominal.
    
    870 740
     -}
    
    871 741
     reifyRoles :: Name -> Q [Role]
    
    872
    -reifyRoles nm = runHandler1 mReifyRoles nm
    
    742
    +reifyRoles = runHandler1 mReifyRoles
    
    873 743
     
    
    874 744
     -- | @reifyAnnotations target@ returns the list of annotations
    
    875 745
     -- associated with @target@.  Only the annotations that are
    
    876 746
     -- appropriately typed is returned.  So if you have @Int@ and @String@
    
    877 747
     -- annotations for the same target, you have to call this function twice.
    
    878 748
     reifyAnnotations :: Data a => AnnLookup -> Q [a]
    
    879
    -reifyAnnotations an = runHandler1 mReifyAnnotations an
    
    749
    +reifyAnnotations = runHandler1 mReifyAnnotations
    
    880 750
     
    
    881 751
     -- | @reifyModule mod@ looks up information about module @mod@.  To
    
    882 752
     -- look up the current module, call this function with the return
    
    883 753
     -- value of 'Language.Haskell.TH.Lib.thisModule'.
    
    884 754
     reifyModule :: Module -> Q ModuleInfo
    
    885
    -reifyModule m = runHandler1 mReifyModule m
    
    755
    +reifyModule = runHandler1 mReifyModule
    
    886 756
     
    
    887 757
     -- | @reifyConStrictness nm@ looks up the strictness information for the fields
    
    888 758
     -- of the constructor with the name @nm@. Note that the strictness information
    
    ... ... @@ -897,7 +767,7 @@ reifyModule m = runHandler1 mReifyModule m
    897 767
     -- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the
    
    898 768
     -- @-XStrictData@ language extension was enabled.
    
    899 769
     reifyConStrictness :: Name -> Q [DecidedStrictness]
    
    900
    -reifyConStrictness n = runHandler1 mReifyConStrictness n
    
    770
    +reifyConStrictness = runHandler1 mReifyConStrictness
    
    901 771
     
    
    902 772
     -- | Is the list of instances returned by 'reifyInstances' nonempty?
    
    903 773
     --
    
    ... ... @@ -951,7 +821,7 @@ getPackageRoot = runHandler mGetPackageRoot
    951 821
     --   * The state of the directory is read at the interface generation time,
    
    952 822
     --     not at the time of the function call.
    
    953 823
     addDependentDirectory :: FilePath -> Q ()
    
    954
    -addDependentDirectory dp = runHandler1 mAddDependentDirectory dp
    
    824
    +addDependentDirectory = runHandler1 mAddDependentDirectory
    
    955 825
     
    
    956 826
     -- | Record external files that runIO is using (dependent upon).
    
    957 827
     -- The compiler can then recognize that it should re-compile the Haskell file
    
    ... ... @@ -965,17 +835,17 @@ addDependentDirectory dp = runHandler1 mAddDependentDirectory dp
    965 835
     --
    
    966 836
     --   * The dependency is based on file content, not a modification time
    
    967 837
     addDependentFile :: FilePath -> Q ()
    
    968
    -addDependentFile fp = runHandler1 mAddDependentFile fp
    
    838
    +addDependentFile = runHandler1 mAddDependentFile
    
    969 839
     
    
    970 840
     -- | Obtain a temporary file path with the given suffix. The compiler will
    
    971 841
     -- delete this file after compilation.
    
    972 842
     addTempFile :: String -> Q FilePath
    
    973
    -addTempFile suffix = runHandler1 mAddTempFile suffix
    
    843
    +addTempFile = runHandler1 mAddTempFile
    
    974 844
     
    
    975 845
     -- | Add additional top-level declarations. The added declarations will be type
    
    976 846
     -- checked along with the current declaration group.
    
    977 847
     addTopDecls :: [Dec] -> Q ()
    
    978
    -addTopDecls ds = runHandler1 mAddTopDecls ds
    
    848
    +addTopDecls = runHandler1 mAddTopDecls
    
    979 849
     
    
    980 850
     -- | Same as 'addForeignSource', but expects to receive a path pointing to the
    
    981 851
     -- foreign file instead of a 'String' of its contents. Consider using this in
    
    ... ... @@ -984,7 +854,7 @@ addTopDecls ds = runHandler1 mAddTopDecls ds
    984 854
     -- This is a good alternative to 'addForeignSource' when you are trying to
    
    985 855
     -- directly link in an object file.
    
    986 856
     addForeignFilePath :: ForeignSrcLang -> FilePath -> Q ()
    
    987
    -addForeignFilePath lang fp = runHandler2 mAddForeignFilePath lang fp
    
    857
    +addForeignFilePath = runHandler2 mAddForeignFilePath
    
    988 858
     
    
    989 859
     -- | Add a finalizer that will run in the Q monad after the current module has
    
    990 860
     -- been type checked. This only makes sense when run within a top-level splice.
    
    ... ... @@ -993,7 +863,7 @@ addForeignFilePath lang fp = runHandler2 mAddForeignFilePath lang fp
    993 863
     -- 'reify' is able to find the local definitions when executed inside the
    
    994 864
     -- finalizer.
    
    995 865
     addModFinalizer :: Q () -> Q ()
    
    996
    -addModFinalizer act = runHandler1 mAddModFinalizer act
    
    866
    +addModFinalizer = runHandler1 mAddModFinalizer
    
    997 867
     
    
    998 868
     -- | Adds a core plugin to the compilation pipeline.
    
    999 869
     --
    
    ... ... @@ -1003,7 +873,7 @@ addModFinalizer act = runHandler1 mAddModFinalizer act
    1003 873
     -- to tell the compiler that we needed to compile first a plugin module in the
    
    1004 874
     -- current package.
    
    1005 875
     addCorePlugin :: String -> Q ()
    
    1006
    -addCorePlugin plugin = runHandler1 mAddCorePlugin plugin
    
    876
    +addCorePlugin = runHandler1 mAddCorePlugin
    
    1007 877
     
    
    1008 878
     -- | Get state from the 'Q' monad. The state maintained by 'Q' is isomorphic to
    
    1009 879
     -- a type-indexed finite map. That is,
    
    ... ... @@ -1022,11 +892,11 @@ getQ = runHandler mGetQ
    1022 892
     -- | Replace the state in the 'Q' monad. Note that the state is local to the
    
    1023 893
     -- Haskell module in which the Template Haskell expression is executed.
    
    1024 894
     putQ :: Typeable a => a -> Q ()
    
    1025
    -putQ x = runHandler1 mPutQ x
    
    895
    +putQ = runHandler1 mPutQ
    
    1026 896
     
    
    1027 897
     -- | Determine whether the given language extension is enabled in the 'Q' monad.
    
    1028 898
     isExtEnabled :: Extension -> Q Bool
    
    1029
    -isExtEnabled ext = runHandler1 mIsExtEnabled ext
    
    899
    +isExtEnabled = runHandler1 mIsExtEnabled
    
    1030 900
     
    
    1031 901
     -- | List all enabled language extensions.
    
    1032 902
     extsEnabled :: Q [Extension]
    
    ... ... @@ -1049,49 +919,18 @@ extsEnabled = runHandler mExtsEnabled
    1049 919
     -- Adding documentation to anything outside of the current module will cause an
    
    1050 920
     -- error.
    
    1051 921
     putDoc :: DocLoc -> String -> Q ()
    
    1052
    -putDoc t s = runHandler2 mPutDoc t s
    
    922
    +putDoc = runHandler2 mPutDoc
    
    1053 923
     
    
    1054 924
     -- | Retrieves the Haddock documentation at the specified location, if one
    
    1055 925
     -- exists.
    
    1056 926
     -- It can be used to read documentation on things defined outside of the current
    
    1057 927
     -- module, provided that those modules were compiled with the @-haddock@ flag.
    
    1058 928
     getDoc :: DocLoc -> Q (Maybe String)
    
    1059
    -getDoc n = runHandler1 mGetDoc n
    
    929
    +getDoc = runHandler1 mGetDoc
    
    1060 930
     
    
    1061 931
     instance MonadIO Q where
    
    1062 932
       liftIO = runIO
    
    1063 933
     
    
    1064
    -instance Quasi Q where
    
    1065
    -  qRunQ               = id
    
    1066
    -  qNewName            = newName
    
    1067
    -  qReport             = report
    
    1068
    -  qRecover            = recover
    
    1069
    -  qReify              = reify
    
    1070
    -  qReifyFixity        = reifyFixity
    
    1071
    -  qReifyType          = reifyType
    
    1072
    -  qReifyInstances     = reifyInstances
    
    1073
    -  qReifyRoles         = reifyRoles
    
    1074
    -  qReifyAnnotations   = reifyAnnotations
    
    1075
    -  qReifyModule        = reifyModule
    
    1076
    -  qReifyConStrictness = reifyConStrictness
    
    1077
    -  qLookupName         = lookupName
    
    1078
    -  qLocation           = location
    
    1079
    -  qGetPackageRoot     = getPackageRoot
    
    1080
    -  qAddDependentFile   = addDependentFile
    
    1081
    -  qAddDependentDirectory = addDependentDirectory
    
    1082
    -  qAddTempFile        = addTempFile
    
    1083
    -  qAddTopDecls        = addTopDecls
    
    1084
    -  qAddForeignFilePath = addForeignFilePath
    
    1085
    -  qAddModFinalizer    = addModFinalizer
    
    1086
    -  qAddCorePlugin      = addCorePlugin
    
    1087
    -  qGetQ               = getQ
    
    1088
    -  qPutQ               = putQ
    
    1089
    -  qIsExtEnabled       = isExtEnabled
    
    1090
    -  qExtsEnabled        = extsEnabled
    
    1091
    -  qPutDoc             = putDoc
    
    1092
    -  qGetDoc             = getDoc
    
    1093
    -
    
    1094
    -
    
    1095 934
     ----------------------------------------------------
    
    1096 935
     -- The following operations are used solely in GHC.HsToCore.Quote when
    
    1097 936
     -- desugaring brackets. They are not necessary for the user, who can use
    

  • libraries/template-haskell/Language/Haskell/TH/Syntax.hs
    ... ... @@ -504,3 +504,167 @@ pattern SpecialiseP nm ty inl phases = SpecialiseEP Nothing [] (SigE (VarE nm) t
    504 504
     
    
    505 505
     unQ :: Q a -> (forall m. Quasi m => m a)
    
    506 506
     unQ m =  runQ m
    
    507
    +
    
    508
    +-----------------------------------------------------
    
    509
    +--
    
    510
    +--              The Quasi class
    
    511
    +--
    
    512
    +-----------------------------------------------------
    
    513
    +
    
    514
    +class (MonadIO m, MonadFail m) => Quasi m where
    
    515
    +  qRunQ :: Q a -> m a
    
    516
    +  -- | Fresh names. See 'newName'.
    
    517
    +  qNewName :: String -> m Name
    
    518
    +
    
    519
    +  ------- Error reporting and recovery -------
    
    520
    +  -- | Report an error (True) or warning (False)
    
    521
    +  -- ...but carry on; use 'fail' to stop. See 'report'.
    
    522
    +  qReport  :: Bool -> String -> m ()
    
    523
    +
    
    524
    +  -- | See 'recover'.
    
    525
    +  qRecover :: m a -- ^ the error handler
    
    526
    +           -> m a -- ^ action which may fail
    
    527
    +           -> m a -- ^ Recover from the monadic 'fail'
    
    528
    +
    
    529
    +  ------- Inspect the type-checker's environment -------
    
    530
    +  -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
    
    531
    +  qLookupName :: Bool -> String -> m (Maybe Name)
    
    532
    +  -- | See 'reify'.
    
    533
    +  qReify          :: Name -> m Info
    
    534
    +  -- | See 'reifyFixity'.
    
    535
    +  qReifyFixity    :: Name -> m (Maybe Fixity)
    
    536
    +  -- | See 'reifyType'.
    
    537
    +  qReifyType      :: Name -> m Type
    
    538
    +  -- | Is (n tys) an instance? Returns list of matching instance Decs (with
    
    539
    +  -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
    
    540
    +  qReifyInstances :: Name -> [Type] -> m [Dec]
    
    541
    +  -- | See 'reifyRoles'.
    
    542
    +  qReifyRoles         :: Name -> m [Role]
    
    543
    +  -- | See 'reifyAnnotations'.
    
    544
    +  qReifyAnnotations   :: Data a => AnnLookup -> m [a]
    
    545
    +  -- | See 'reifyModule'.
    
    546
    +  qReifyModule        :: Module -> m ModuleInfo
    
    547
    +  -- | See 'reifyConStrictness'.
    
    548
    +  qReifyConStrictness :: Name -> m [DecidedStrictness]
    
    549
    +
    
    550
    +  -- | See 'location'.
    
    551
    +  qLocation :: m Loc
    
    552
    +
    
    553
    +  -- | Input/output (dangerous). See 'runIO'.
    
    554
    +  qRunIO :: IO a -> m a
    
    555
    +  qRunIO = liftIO
    
    556
    +  -- | See 'getPackageRoot'.
    
    557
    +  qGetPackageRoot :: m FilePath
    
    558
    +
    
    559
    +  -- | See 'addDependentFile'.
    
    560
    +  qAddDependentFile :: FilePath -> m ()
    
    561
    +
    
    562
    +  -- | See 'addDependentDirectory'.
    
    563
    +  qAddDependentDirectory :: FilePath -> m ()
    
    564
    +
    
    565
    +  -- | See 'addTempFile'.
    
    566
    +  qAddTempFile :: String -> m FilePath
    
    567
    +
    
    568
    +  -- | See 'addTopDecls'.
    
    569
    +  qAddTopDecls :: [Dec] -> m ()
    
    570
    +
    
    571
    +  -- | See 'addForeignFilePath'.
    
    572
    +  qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
    
    573
    +
    
    574
    +  -- | See 'addModFinalizer'.
    
    575
    +  qAddModFinalizer :: Q () -> m ()
    
    576
    +
    
    577
    +  -- | See 'addCorePlugin'.
    
    578
    +  qAddCorePlugin :: String -> m ()
    
    579
    +
    
    580
    +  -- | See 'getQ'.
    
    581
    +  qGetQ :: Typeable a => m (Maybe a)
    
    582
    +
    
    583
    +  -- | See 'putQ'.
    
    584
    +  qPutQ :: Typeable a => a -> m ()
    
    585
    +
    
    586
    +  -- | See 'isExtEnabled'.
    
    587
    +  qIsExtEnabled :: Extension -> m Bool
    
    588
    +  -- | See 'extsEnabled'.
    
    589
    +  qExtsEnabled :: m [Extension]
    
    590
    +
    
    591
    +  -- | See 'putDoc'.
    
    592
    +  qPutDoc :: DocLoc -> String -> m ()
    
    593
    +  -- | See 'getDoc'.
    
    594
    +  qGetDoc :: DocLoc -> m (Maybe String)
    
    595
    +
    
    596
    +-----------------------------------------------------
    
    597
    +--      The IO instance of Quasi
    
    598
    +-----------------------------------------------------
    
    599
    +
    
    600
    +--  | This instance is used only when running a Q
    
    601
    +--  computation in the IO monad, usually just to
    
    602
    +--  print the result.  There is no interesting
    
    603
    +--  type environment, so reification isn't going to
    
    604
    +--  work.
    
    605
    +instance Quasi IO where
    
    606
    +  qRunQ (Q m) = m metaHandlersIO
    
    607
    +  qNewName = newNameIO
    
    608
    +
    
    609
    +  qReport True  msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
    
    610
    +  qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
    
    611
    +
    
    612
    +  qLookupName _ _       = badIO "lookupName"
    
    613
    +  qReify _              = badIO "reify"
    
    614
    +  qReifyFixity _        = badIO "reifyFixity"
    
    615
    +  qReifyType _          = badIO "reifyFixity"
    
    616
    +  qReifyInstances _ _   = badIO "reifyInstances"
    
    617
    +  qReifyRoles _         = badIO "reifyRoles"
    
    618
    +  qReifyAnnotations _   = badIO "reifyAnnotations"
    
    619
    +  qReifyModule _        = badIO "reifyModule"
    
    620
    +  qReifyConStrictness _ = badIO "reifyConStrictness"
    
    621
    +  qLocation             = badIO "currentLocation"
    
    622
    +  qRecover _ _          = badIO "recover" -- Maybe we could fix this?
    
    623
    +  qGetPackageRoot       = badIO "getProjectRoot"
    
    624
    +  qAddDependentFile _   = badIO "addDependentFile"
    
    625
    +  qAddTempFile _        = badIO "addTempFile"
    
    626
    +  qAddTopDecls _        = badIO "addTopDecls"
    
    627
    +  qAddForeignFilePath _ _ = badIO "addForeignFilePath"
    
    628
    +  qAddModFinalizer _    = badIO "addModFinalizer"
    
    629
    +  qAddCorePlugin _      = badIO "addCorePlugin"
    
    630
    +  qGetQ                 = badIO "getQ"
    
    631
    +  qPutQ _               = badIO "putQ"
    
    632
    +  qIsExtEnabled _       = badIO "isExtEnabled"
    
    633
    +  qExtsEnabled          = badIO "extsEnabled"
    
    634
    +  qPutDoc _ _           = badIO "putDoc"
    
    635
    +  qGetDoc _             = badIO "getDoc"
    
    636
    +  qAddDependentDirectory _ = badIO "AddDependentDirectory"
    
    637
    +
    
    638
    +badIO :: String -> IO a
    
    639
    +badIO op = do   { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
    
    640
    +                ; fail "Template Haskell failure" }
    
    641
    +
    
    642
    +instance Quasi Q where
    
    643
    +  qRunQ               = id
    
    644
    +  qNewName            = newName
    
    645
    +  qReport             = report
    
    646
    +  qRecover            = recover
    
    647
    +  qReify              = reify
    
    648
    +  qReifyFixity        = reifyFixity
    
    649
    +  qReifyType          = reifyType
    
    650
    +  qReifyInstances     = reifyInstances
    
    651
    +  qReifyRoles         = reifyRoles
    
    652
    +  qReifyAnnotations   = reifyAnnotations
    
    653
    +  qReifyModule        = reifyModule
    
    654
    +  qReifyConStrictness = reifyConStrictness
    
    655
    +  qLookupName         = lookupName
    
    656
    +  qLocation           = location
    
    657
    +  qGetPackageRoot     = getPackageRoot
    
    658
    +  qAddDependentFile   = addDependentFile
    
    659
    +  qAddDependentDirectory = addDependentDirectory
    
    660
    +  qAddTempFile        = addTempFile
    
    661
    +  qAddTopDecls        = addTopDecls
    
    662
    +  qAddForeignFilePath = addForeignFilePath
    
    663
    +  qAddModFinalizer    = addModFinalizer
    
    664
    +  qAddCorePlugin      = addCorePlugin
    
    665
    +  qGetQ               = getQ
    
    666
    +  qPutQ               = putQ
    
    667
    +  qIsExtEnabled       = isExtEnabled
    
    668
    +  qExtsEnabled        = extsEnabled
    
    669
    +  qPutDoc             = putDoc
    
    670
    +  qGetDoc             = getDoc