@@ -3,11 +3,9 @@
33{-# LANGUAGE ScopedTypeVariables #-}
44{-# LANGUAGE UndecidableInstances #-}
55{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE CPP #-}
7−module Language.Haskell.Generate.Monad
8− ( Generate(..), ExpG
9− , runGenerate, newName
10− , returnE
6+module Language.Haskell.Generate.Base
7+ ( ExpM(..), ExpG, ExpType
8+ , runExpM, newName
119 , useValue, useCon, useVar
1210 , caseE
1311 , applyE, applyE2, applyE3, applyE4, applyE5, applyE6
@@ -21,7 +19,6 @@ module Language.Haskell.Generate.Monad
2119 , addDecl
2220 , runModuleM
2321 , generateModule
24− , generateExp
2522 )
2623 where
2724
@@ -34,44 +31,32 @@ import qualified Data.Set as S
3431import Language.Haskell.Exts.Pretty
3532import Language.Haskell.Exts.SrcLoc
3633import Language.Haskell.Exts.Syntax
37−import Language.Haskell.Generate.Expression
38−
39−import Prelude
4034
4135--------------------------------------------------------------------------------
4236-- Generate expressions
4337
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
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)
5142
52−-- | This is a type alias for a Generate action that returns an expression of type 't'.
53−type ExpG t = Generate (Expression t)
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
5446
55−-- | Use a haskell-src-exts Exp as the result of a Generate action.
56−returnE :: Exp -> ExpG t
57−returnE = return . Expression
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
5850
59−-- | Pretty print the expression generated by a given action.
60−generateExp :: ExpG t -> String
61−generateExp = prettyPrint . runExpression . fst . runGenerate
51+unsafeCoerceE :: ExpM t a -> ExpM t' a
52+unsafeCoerceE (ExpM x) = ExpM x
6253
6354-- | Generate a case expression.
6455caseE :: ExpG x -> [(Pat, ExpG t)] -> ExpG t
6556caseE v alt = do
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'
57+ v' <- unsafeCoerceE v
58+ alt' <- mapM (\(p,a) -> fmap (\a' -> Alt noLoc p (UnGuardedAlt a') (BDecls [])) a) alt
59+ return $ Case v' alt'
7560
7661-- | Import a function from a module. This function is polymorphic in the type of the resulting expression,
7762-- you should probably only use this function to define type-restricted specializations.
@@ -82,37 +67,32 @@ caseE v alt = do
8267-- > addInt = useValue "Prelude" $ Symbol "+"
8368--
8469useValue :: String -> Name -> ExpG a
85−useValue md name = Generate $ do
70+useValue md name = ExpM $ do
8671 lift $ tell $ S.singleton $ ModuleName md
87− return $ Expression $ Var $ Qual (ModuleName md) name
72+ return $ Var $ Qual (ModuleName md) name
8873
8974-- | Import a value constructor from a module. Returns the qualified name of the constructor.
90−useCon :: String -> Name -> Generate QName
91−useCon md name = Generate $ do
75+useCon :: String -> Name -> ExpM t QName
76+useCon md name = ExpM $ do
9277 lift $ tell $ S.singleton $ ModuleName md
9378 return $ Qual (ModuleName md) name
9479
9580-- | Use the value of a variable with the given name.
9681useVar :: Name -> ExpG t
97−useVar name = return $ Expression $ Var $ UnQual name
82+useVar name = return $ Var $ UnQual name
9883
9984-- | Generate a new unique variable name with the given prefix. Note that this new variable name
10085-- is only unique relative to other variable names generated by this function.
101−newName :: String -> Generate Name
102−newName pref = Generate $ do
86+newName :: String -> ExpM t Name
87+newName pref = ExpM $ do
10388 i <- get <* modify succ
10489 return $ Ident $ pref ++ show i
10590
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−--
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.
11696class GenExp t where
11797 type GenExpType t :: *
11898
@@ -123,41 +103,36 @@ instance GenExp (ExpG a) where
123103 type GenExpType (ExpG a) = a
124104 expr = id
125105
126−instance GenExp (Expression t) where
127− type GenExpType (Expression t) = t
128− expr = return
129−
130106instance GenExp Char where
131107 type GenExpType Char = Char
132− expr = return . Expression . Lit . Char
108+ expr = return . Lit . Char
133109
134110instance GenExp Integer where
135111 type GenExpType Integer = Integer
136− expr = return . Expression . Lit . Int
112+ expr = return . Lit . Int
137113
138114instance GenExp Rational where
139115 type GenExpType Rational = Rational
140− expr = return . Expression . Lit . Frac
116+ expr = return . Lit . Frac
141117
142118instance GenExp a => GenExp [a] where
143119 type GenExpType [a] = [GenExpType a]
144− expr = Generate . fmap (Expression . List . map runExpression) . mapM (unGenerate . expr)
120+ expr = ExpM . fmap List . mapM (unExpM . expr)
145121
146122instance GenExp x => GenExp (ExpG a -> x) where
147123 type GenExpType (ExpG a -> x) = a -> GenExpType x
148124 expr f = do
149125 pvarName <- newName "pvar_"
150− body <- expr $ f $ return $ Expression $ Var $ UnQual pvarName
151− return $ Expression $ Lambda noLoc [PVar pvarName] $ runExpression body
126+ body <- unsafeCoerceE $ expr $ f $ return $ Var $ UnQual pvarName
127+ return $ Lambda noLoc [PVar pvarName] body
152128
153129--------------------------------------------------------------------------------
154130-- Apply functions
155131
156132-- | Apply a function in a haskell expression to a value.
157133applyE :: ExpG (a -> b) -> ExpG a -> ExpG b
158−applyE a b = wrap $ liftM (foldl1 App) $ sequence [unwrap a, unwrap b]
159− where wrap = fmap Expression
160− unwrap = fmap runExpression
134+applyE a b = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b]
135+ where ce = unsafeCoerceE
161136
162137-- | Operator for 'applyE'.
163138(<>$) :: ExpG (a -> b) -> ExpG a -> ExpG b
@@ -167,33 +142,28 @@ infixl 1 <>$
167142
168143-- | ApplyE for 2 arguments
169144applyE2 :: ExpG (a -> b -> c) -> ExpG a -> ExpG b -> ExpG c
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
145+applyE2 a b c = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c]
146+ where ce = unsafeCoerceE
173147
174148-- | Apply a function to 3 arguments
175149applyE3 :: ExpG (a -> b -> c -> d) -> ExpG a -> ExpG b -> ExpG c -> ExpG d
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
150+applyE3 a b c d = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c,ce d]
151+ where ce = unsafeCoerceE
179152
180153-- | Apply a function to 4 arguments
181154applyE4 :: ExpG (a -> b -> c -> d -> e) -> ExpG a -> ExpG b -> ExpG c -> ExpG d -> ExpG e
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
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
185157
186158-- | Apply a function to 5 arguments
187159applyE5 :: ExpG (a -> b -> c -> d -> e -> f) -> ExpG a -> ExpG b -> ExpG c -> ExpG d -> ExpG e -> ExpG f
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
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
191162
192163-- | Apply a function to 6 arguments
193164applyE6 :: ExpG (a -> b -> c -> d -> e -> f -> g) -> ExpG a -> ExpG b -> ExpG c -> ExpG d -> ExpG e -> ExpG f -> ExpG g
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
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
197167
198168--------------------------------------------------------------------------------
199169-- Generate modules
@@ -210,35 +180,23 @@ data FunRef t = FunRef Name
210180
211181instance GenExp (FunRef t) where
212182 type GenExpType (FunRef t) = t
213− expr (FunRef n) = return $ Expression $ Var $ UnQual n
183+ expr (FunRef n) = return $ Var $ UnQual n
214184
215185-- | Generate a ExportSpec for a given function item.
216186exportFun :: 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
220187exportFun (FunRef name) = EVar (UnQual name)
221−#endif
222188
223189-- | 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.
224190addDecl :: Name -> ExpG t -> ModuleM (FunRef t)
225191addDecl name e = ModuleM $ do
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
192+ let (body, mods) = runExpM e
193+ tell (mods, [FunBind [Match noLoc name [] Nothing (UnGuardedRhs body) $ BDecls []]])
232194 return $ FunRef name
233195
234196-- | Extract the Module from a module generator.
235197runModuleM :: ModuleG -> String -> Module
236198runModuleM (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
240199 Module noLoc (ModuleName name) [] Nothing export (map (\md -> ImportDecl noLoc md True False Nothing Nothing Nothing) $ S.toList imps) decls
241−#endif
242200 where (export, (imps, decls)) = runWriter act
243201
244202-- | Generate the source code for a module.