@@ -3,6 +3,7 @@
33{-# LANGUAGE ScopedTypeVariables #-}
44{-# LANGUAGE UndecidableInstances #-}
55{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE CPP #-}
67module Language.Haskell.Generate.Monad
78 ( Generate(..), ExpG
89 , runGenerate, newName
@@ -35,19 +36,27 @@ import Language.Haskell.Exts.SrcLoc
3536import Language.Haskell.Exts.Syntax
3637import Language.Haskell.Generate.Expression
3738
39+import Prelude
40+
3841--------------------------------------------------------------------------------
3942-- Generate expressions
4043
44+-- | This monad keeps track of a counter for generating unique names and the set of modules
45+-- that are needed for the expression.
4146newtype Generate a = Generate { unGenerate :: StateT Integer (Writer (S.Set ModuleName)) a } deriving (Functor, Applicative, Monad)
4247
48+-- | Extract the set of modules and the value from a Generate action.
4349runGenerate :: Generate a -> (a, S.Set ModuleName)
4450runGenerate (Generate a) = runWriter $ evalStateT a 0
4551
52+-- | This is a type alias for a Generate action that returns an expression of type 't'.
4653type ExpG t = Generate (Expression t)
4754
55+-- | Use a haskell-src-exts Exp as the result of a Generate action.
4856returnE :: Exp -> ExpG t
4957returnE = return . Expression
5058
59+-- | Pretty print the expression generated by a given action.
5160generateExp :: ExpG t -> String
5261generateExp = prettyPrint . runExpression . fst . runGenerate
5362
@@ -55,7 +64,13 @@ generateExp = prettyPrint . runExpression . fst . runGenerate
5564caseE :: ExpG x -> [(Pat, ExpG t)] -> ExpG t
5665caseE v alt = do
5766 v' <- v
67+#if MIN_VERSION_haskell_src_exts(1,17,0)
68+ alt' <- mapM (\(p,a) -> fmap (\a' -> Alt noLoc p (UnGuardedRhs $ runExpression a') Nothing) a) alt
69+#elif MIN_VERSION_haskell_src_exts(1,16,0)
70+ alt' <- mapM (\(p,a) -> fmap (\a' -> Alt noLoc p (UnGuardedRhs $ runExpression a') (BDecls [])) a) alt
71+#else
5872 alt' <- mapM (\(p,a) -> fmap (\a' -> Alt noLoc p (UnGuardedAlt $ runExpression a') (BDecls [])) a) alt
73+#endif
5974 return $ Expression $ Case (runExpression v') alt'
6075
6176-- | Import a function from a module. This function is polymorphic in the type of the resulting expression,
@@ -88,7 +103,16 @@ newName pref = Generate $ do
88103 i <- get <* modify succ
89104 return $ Ident $ pref ++ show i
90105
91−-- | Generate a expression from a haskell value.
106+-- | Generate a expression from a haskell value. This can for example be used to create lambdas:
107+--
108+-- >>> putStrLn $ generateExp $ expr (\x f -> f <>$ x)
109+-- \ pvar_0 -> \ pvar_1 -> pvar_1 pvar_0
110+--
111+-- Or string literals:
112+--
113+-- >>> putStrLn $ generateExp $ expr "I'm a string!"
114+-- ['I', '\'', 'm', ' ', 'a', ' ', 's', 't', 'r', 'i', 'n', 'g', '!']
115+--
92116class GenExp t where
93117 type GenExpType t :: *
94118
@@ -129,14 +153,12 @@ instance GenExp x => GenExp (ExpG a -> x) where
129153--------------------------------------------------------------------------------
130154-- Apply functions
131155
132−
133156-- | Apply a function in a haskell expression to a value.
134157applyE :: ExpG (a -> b) -> ExpG a -> ExpG b
135158applyE a b = wrap $ liftM (foldl1 App) $ sequence [unwrap a, unwrap b]
136159 where wrap = fmap Expression
137160 unwrap = fmap runExpression
138161
139−
140162-- | Operator for 'applyE'.
141163(<>$) :: ExpG (a -> b) -> ExpG a -> ExpG b
142164(<>$) = applyE
@@ -192,19 +214,31 @@ instance GenExp (FunRef t) where
192214
193215-- | Generate a ExportSpec for a given function item.
194216exportFun :: FunRef t -> ExportSpec
217+#if MIN_VERSION_haskell_src_exts(1,16,0) && !MIN_VERSION_haskell_src_exts(1,17,0)
218+exportFun (FunRef name) = EVar NoNamespace (UnQual name)
219+#else
195220exportFun (FunRef name) = EVar (UnQual name)
221+#endif
196222
197223-- | Add a declaration to the module. Return a reference to it that can be used to either apply the function to some values or export it.
198224addDecl :: Name -> ExpG t -> ModuleM (FunRef t)
199225addDecl name e = ModuleM $ do
200226 let (body, mods) = runGenerate e
227+#if MIN_VERSION_haskell_src_exts(1,17,0)
228+ tell (mods, [FunBind [Match noLoc name [] Nothing (UnGuardedRhs $ runExpression body) Nothing]])
229+#else
201230 tell (mods, [FunBind [Match noLoc name [] Nothing (UnGuardedRhs $ runExpression body) $ BDecls []]])
231+#endif
202232 return $ FunRef name
203233
204234-- | Extract the Module from a module generator.
205235runModuleM :: ModuleG -> String -> Module
206236runModuleM (ModuleM act) name =
237+#if MIN_VERSION_haskell_src_exts(1,16,0)
238+ Module noLoc (ModuleName name) [] Nothing export (map (\md -> ImportDecl noLoc md True False False Nothing Nothing Nothing) $ S.toList imps) decls
239+#else
207240 Module noLoc (ModuleName name) [] Nothing export (map (\md -> ImportDecl noLoc md True False Nothing Nothing Nothing) $ S.toList imps) decls
241+#endif
208242 where (export, (imps, decls)) = runWriter act
209243
210244-- | Generate the source code for a module.