@@ -3,9 +3,11 @@
33{-# LANGUAGE ScopedTypeVariables #-}
44{-# LANGUAGE UndecidableInstances #-}
55{-# LANGUAGE FlexibleInstances #-}
6−module Language.Haskell.Generate.Base
7− ( ExpM(..), ExpG, ExpType
8− , runExpM, newName
6+{-# LANGUAGE CPP #-}
7+module Language.Haskell.Generate.Monad
8+ ( Generate(..), ExpG
9+ , runGenerate, newName
10+ , returnE
911 , useValue, useCon, useVar
1012 , caseE
1113 , applyE, applyE2, applyE3, applyE4, applyE5, applyE6
@@ -19,6 +21,7 @@ module Language.Haskell.Generate.Base
1921 , addDecl
2022 , runModuleM
2123 , generateModule
24+ , generateExp
2225 )
2326 where
2427
@@ -31,32 +34,44 @@ import qualified Data.Set as S
3134import Language.Haskell.Exts.Pretty
3235import Language.Haskell.Exts.SrcLoc
3336import Language.Haskell.Exts.Syntax
37+import Language.Haskell.Generate.Expression
38+
39+import Prelude
3440
3541--------------------------------------------------------------------------------
3642-- Generate expressions
3743
38−-- | A ExpM is a monad used to track the imports that are needed for a given expression. Usually, you don't have to use
39−-- this type directly, but use combinators to combine several ExpM into bigger expressions. The t type parameter tracks
40−-- the type of the expression, so you don't accidently build expression that don't type check.
41−newtype ExpM t a = ExpM { unExpM :: StateT Integer (Writer (S.Set ModuleName)) a } deriving (Functor, Applicative, Monad)
44+-- | This monad keeps track of a counter for generating unique names and the set of modules
45+-- that are needed for the expression.
46+newtype Generate a = Generate { unGenerate :: StateT Integer (Writer (S.Set ModuleName)) a } deriving (Functor, Applicative, Monad)
47+
48+-- | Extract the set of modules and the value from a Generate action.
49+runGenerate :: Generate a -> (a, S.Set ModuleName)
50+runGenerate (Generate a) = runWriter $ evalStateT a 0
4251
43−-- | The ExpG type is a ExpM computation that returns an expression. Usually, this is the end result of a function generating
44−-- a haskell expression
45−type ExpG t = ExpM t Exp
52+-- | This is a type alias for a Generate action that returns an expression of type 't'.
53+type ExpG t = Generate (Expression t)
4654
47−-- | Evaluate a ExpM action, returning the needed modules and the value.
48−runExpM :: ExpM t a -> (a, S.Set ModuleName)
49−runExpM (ExpM expt) = runWriter $ evalStateT expt 0
55+-- | Use a haskell-src-exts Exp as the result of a Generate action.
56+returnE :: Exp -> ExpG t
57+returnE = return . Expression
5058
51−unsafeCoerceE :: ExpM t a -> ExpM t' a
52−unsafeCoerceE (ExpM x) = ExpM x
59+-- | Pretty print the expression generated by a given action.
60+generateExp :: ExpG t -> String
61+generateExp = prettyPrint . runExpression . fst . runGenerate
5362
5463-- | Generate a case expression.
5564caseE :: ExpG x -> [(Pat, ExpG t)] -> ExpG t
5665caseE v alt = do
57− v' <- unsafeCoerceE v
58− alt' <- mapM (\(p,a) -> fmap (\a' -> Alt noLoc p (UnGuardedAlt a') (BDecls [])) a) alt
59− return $ Case v' alt'
66+ 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
72+ alt' <- mapM (\(p,a) -> fmap (\a' -> Alt noLoc p (UnGuardedAlt $ runExpression a') (BDecls [])) a) alt
73+#endif
74+ 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,
6277-- you should probably only use this function to define type-restricted specializations.
@@ -67,32 +82,37 @@ caseE v alt = do
6782-- > addInt = useValue "Prelude" $ Symbol "+"
6883--
6984useValue :: String -> Name -> ExpG a
70−useValue md name = ExpM $ do
85+useValue md name = Generate $ do
7186 lift $ tell $ S.singleton $ ModuleName md
72− return $ Var $ Qual (ModuleName md) name
87+ return $ Expression $ Var $ Qual (ModuleName md) name
7388
7489-- | Import a value constructor from a module. Returns the qualified name of the constructor.
75−useCon :: String -> Name -> ExpM t QName
76−useCon md name = ExpM $ do
90+useCon :: String -> Name -> Generate QName
91+useCon md name = Generate $ do
7792 lift $ tell $ S.singleton $ ModuleName md
7893 return $ Qual (ModuleName md) name
7994
8095-- | Use the value of a variable with the given name.
8196useVar :: Name -> ExpG t
82−useVar name = return $ Var $ UnQual name
97+useVar name = return $ Expression $ Var $ UnQual name
8398
8499-- | Generate a new unique variable name with the given prefix. Note that this new variable name
85100-- is only unique relative to other variable names generated by this function.
86−newName :: String -> ExpM t Name
87−newName pref = ExpM $ do
101+newName :: String -> Generate Name
102+newName pref = Generate $ do
88103 i <- get <* modify succ
89104 return $ Ident $ pref ++ show i
90105
91−-- | This type family can be used to get the type associated with some expression.
92−type family ExpType a :: *
93−type instance ExpType (ExpM t a) = t
94−
95−-- | 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+--
96116class GenExp t where
97117 type GenExpType t :: *
98118
@@ -103,36 +123,41 @@ instance GenExp (ExpG a) where
103123 type GenExpType (ExpG a) = a
104124 expr = id
105125
126+instance GenExp (Expression t) where
127+ type GenExpType (Expression t) = t
128+ expr = return
129+
106130instance GenExp Char where
107131 type GenExpType Char = Char
108− expr = return . Lit . Char
132+ expr = return . Expression . Lit . Char
109133
110134instance GenExp Integer where
111135 type GenExpType Integer = Integer
112− expr = return . Lit . Int
136+ expr = return . Expression . Lit . Int
113137
114138instance GenExp Rational where
115139 type GenExpType Rational = Rational
116− expr = return . Lit . Frac
140+ expr = return . Expression . Lit . Frac
117141
118142instance GenExp a => GenExp [a] where
119143 type GenExpType [a] = [GenExpType a]
120− expr = ExpM . fmap List . mapM (unExpM . expr)
144+ expr = Generate . fmap (Expression . List . map runExpression) . mapM (unGenerate . expr)
121145
122146instance GenExp x => GenExp (ExpG a -> x) where
123147 type GenExpType (ExpG a -> x) = a -> GenExpType x
124148 expr f = do
125149 pvarName <- newName "pvar_"
126− body <- unsafeCoerceE $ expr $ f $ return $ Var $ UnQual pvarName
127− return $ Lambda noLoc [PVar pvarName] body
150+ body <- expr $ f $ return $ Expression $ Var $ UnQual pvarName
151+ return $ Expression $ Lambda noLoc [PVar pvarName] $ runExpression body
128152
129153--------------------------------------------------------------------------------
130154-- Apply functions
131155
132156-- | Apply a function in a haskell expression to a value.
133157applyE :: ExpG (a -> b) -> ExpG a -> ExpG b
134−applyE a b = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b]
135− where ce = unsafeCoerceE
158+applyE a b = wrap $ liftM (foldl1 App) $ sequence [unwrap a, unwrap b]
159+ where wrap = fmap Expression
160+ unwrap = fmap runExpression
136161
137162-- | Operator for 'applyE'.
138163(<>$) :: ExpG (a -> b) -> ExpG a -> ExpG b
@@ -142,28 +167,33 @@ infixl 1 <>$
142167
143168-- | ApplyE for 2 arguments
144169applyE2 :: ExpG (a -> b -> c) -> ExpG a -> ExpG b -> ExpG c
145−applyE2 a b c = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c]
146− where ce = unsafeCoerceE
170+applyE2 a b c = wrap $ liftM (foldl1 App) $ sequence [unwrap a,unwrap b,unwrap c]
171+ where wrap = fmap Expression
172+ unwrap = fmap runExpression
147173
148174-- | Apply a function to 3 arguments
149175applyE3 :: ExpG (a -> b -> c -> d) -> ExpG a -> ExpG b -> ExpG c -> ExpG d
150−applyE3 a b c d = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c,ce d]
151− where ce = unsafeCoerceE
176+applyE3 a b c d = wrap $ liftM (foldl1 App) $ sequence [unwrap a,unwrap b,unwrap c,unwrap d]
177+ where wrap = fmap Expression
178+ unwrap = fmap runExpression
152179
153180-- | Apply a function to 4 arguments
154181applyE4 :: ExpG (a -> b -> c -> d -> e) -> ExpG a -> ExpG b -> ExpG c -> ExpG d -> ExpG e
155−applyE4 a b c d e = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c,ce d,ce e]
156− where ce = unsafeCoerceE
182+applyE4 a b c d e = wrap $ liftM (foldl1 App) $ sequence [unwrap a,unwrap b,unwrap c,unwrap d,unwrap e]
183+ where wrap = fmap Expression
184+ unwrap = fmap runExpression
157185
158186-- | Apply a function to 5 arguments
159187applyE5 :: ExpG (a -> b -> c -> d -> e -> f) -> ExpG a -> ExpG b -> ExpG c -> ExpG d -> ExpG e -> ExpG f
160−applyE5 a b c d e f = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c,ce d,ce e,ce f]
161− where ce = unsafeCoerceE
188+applyE5 a b c d e f = wrap $ liftM (foldl1 App) $ sequence [unwrap a,unwrap b,unwrap c,unwrap d,unwrap e,unwrap f]
189+ where wrap = fmap Expression
190+ unwrap = fmap runExpression
162191
163192-- | Apply a function to 6 arguments
164193applyE6 :: ExpG (a -> b -> c -> d -> e -> f -> g) -> ExpG a -> ExpG b -> ExpG c -> ExpG d -> ExpG e -> ExpG f -> ExpG g
165−applyE6 a b c d e f g = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c,ce d,ce e,ce f,ce g]
166− where ce = unsafeCoerceE
194+applyE6 a b c d e f g = wrap $ liftM (foldl1 App) $ sequence [unwrap a,unwrap b,unwrap c,unwrap d,unwrap e,unwrap f,unwrap g]
195+ where wrap = fmap Expression
196+ unwrap = fmap runExpression
167197
168198--------------------------------------------------------------------------------
169199-- Generate modules
@@ -180,23 +210,35 @@ data FunRef t = FunRef Name
180210
181211instance GenExp (FunRef t) where
182212 type GenExpType (FunRef t) = t
183− expr (FunRef n) = return $ Var $ UnQual n
213+ expr (FunRef n) = return $ Expression $ Var $ UnQual n
184214
185215-- | Generate a ExportSpec for a given function item.
186216exportFun :: 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
187220exportFun (FunRef name) = EVar (UnQual name)
221+#endif
188222
189223-- | 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.
190224addDecl :: Name -> ExpG t -> ModuleM (FunRef t)
191225addDecl name e = ModuleM $ do
192− let (body, mods) = runExpM e
193− tell (mods, [FunBind [Match noLoc name [] Nothing (UnGuardedRhs body) $ BDecls []]])
226+ 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
230+ tell (mods, [FunBind [Match noLoc name [] Nothing (UnGuardedRhs $ runExpression body) $ BDecls []]])
231+#endif
194232 return $ FunRef name
195233
196234-- | Extract the Module from a module generator.
197235runModuleM :: ModuleG -> String -> Module
198236runModuleM (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
199240 Module noLoc (ModuleName name) [] Nothing export (map (\md -> ImportDecl noLoc md True False Nothing Nothing Nothing) $ S.toList imps) decls
241+#endif
200242 where (export, (imps, decls)) = runWriter act
201243
202244-- | Generate the source code for a module.