@@ -3,9 +3,10 @@
33{-# LANGUAGE ScopedTypeVariables #-}
44{-# LANGUAGE UndecidableInstances #-}
55{-# LANGUAGE FlexibleInstances #-}
6−module Language.Haskell.Generate.Base
7− ( ExpM(..), ExpG, ExpType
8− , runExpM, newName
6+module Language.Haskell.Generate.Monad
7+ ( Generate(..), ExpG
8+ , runGenerate, newName
9+ , returnE
910 , useValue, useCon, useVar
1011 , caseE
1112 , applyE, applyE2, applyE3, applyE4, applyE5, applyE6
@@ -19,6 +20,7 @@ module Language.Haskell.Generate.Base
1920 , addDecl
2021 , runModuleM
2122 , generateModule
23+ , generateExp
2224 )
2325 where
2426
@@ -31,32 +33,30 @@ import qualified Data.Set as S
3133import Language.Haskell.Exts.Pretty
3234import Language.Haskell.Exts.SrcLoc
3335import Language.Haskell.Exts.Syntax
36+import Language.Haskell.Generate.Expression
3437
3538--------------------------------------------------------------------------------
3639-- Generate expressions
3740
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)
41+newtype Generate a = Generate { unGenerate :: StateT Integer (Writer (S.Set ModuleName)) a } deriving (Functor, Applicative, Monad)
4242
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
43+runGenerate :: Generate a -> (a, S.Set ModuleName)
44+runGenerate (Generate a) = runWriter $ evalStateT a 0
4645
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
46+type ExpG t = Generate (Expression t)
5047
51−unsafeCoerceE :: ExpM t a -> ExpM t' a
52−unsafeCoerceE (ExpM x) = ExpM x
48+returnE :: Exp -> ExpG t
49+returnE = return . Expression
50+
51+generateExp :: ExpG t -> String
52+generateExp = prettyPrint . runExpression . fst . runGenerate
5353
5454-- | Generate a case expression.
5555caseE :: ExpG x -> [(Pat, ExpG t)] -> ExpG t
5656caseE 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'
57+ v' <- v
58+ alt' <- mapM (\(p,a) -> fmap (\a' -> Alt noLoc p (UnGuardedAlt $ runExpression a') (BDecls [])) a) alt
59+ return $ Expression $ Case (runExpression v') alt'
6060
6161-- | Import a function from a module. This function is polymorphic in the type of the resulting expression,
6262-- you should probably only use this function to define type-restricted specializations.
@@ -67,31 +67,27 @@ caseE v alt = do
6767-- > addInt = useValue "Prelude" $ Symbol "+"
6868--
6969useValue :: String -> Name -> ExpG a
70−useValue md name = ExpM $ do
70+useValue md name = Generate $ do
7171 lift $ tell $ S.singleton $ ModuleName md
72− return $ Var $ Qual (ModuleName md) name
72+ return $ Expression $ Var $ Qual (ModuleName md) name
7373
7474-- | 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
75+useCon :: String -> Name -> Generate QName
76+useCon md name = Generate $ do
7777 lift $ tell $ S.singleton $ ModuleName md
7878 return $ Qual (ModuleName md) name
7979
8080-- | Use the value of a variable with the given name.
8181useVar :: Name -> ExpG t
82−useVar name = return $ Var $ UnQual name
82+useVar name = return $ Expression $ Var $ UnQual name
8383
8484-- | Generate a new unique variable name with the given prefix. Note that this new variable name
8585-- is only unique relative to other variable names generated by this function.
86−newName :: String -> ExpM t Name
87−newName pref = ExpM $ do
86+newName :: String -> Generate Name
87+newName pref = Generate $ do
8888 i <- get <* modify succ
8989 return $ Ident $ pref ++ show i
9090
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−
9591-- | Generate a expression from a haskell value.
9692class GenExp t where
9793 type GenExpType t :: *
@@ -103,36 +99,43 @@ instance GenExp (ExpG a) where
10399 type GenExpType (ExpG a) = a
104100 expr = id
105101
102+instance GenExp (Expression t) where
103+ type GenExpType (Expression t) = t
104+ expr = return
105+
106106instance GenExp Char where
107107 type GenExpType Char = Char
108− expr = return . Lit . Char
108+ expr = return . Expression . Lit . Char
109109
110110instance GenExp Integer where
111111 type GenExpType Integer = Integer
112− expr = return . Lit . Int
112+ expr = return . Expression . Lit . Int
113113
114114instance GenExp Rational where
115115 type GenExpType Rational = Rational
116− expr = return . Lit . Frac
116+ expr = return . Expression . Lit . Frac
117117
118118instance GenExp a => GenExp [a] where
119119 type GenExpType [a] = [GenExpType a]
120− expr = ExpM . fmap List . mapM (unExpM . expr)
120+ expr = Generate . fmap (Expression . List . map runExpression) . mapM (unGenerate . expr)
121121
122122instance GenExp x => GenExp (ExpG a -> x) where
123123 type GenExpType (ExpG a -> x) = a -> GenExpType x
124124 expr f = do
125125 pvarName <- newName "pvar_"
126− body <- unsafeCoerceE $ expr $ f $ return $ Var $ UnQual pvarName
127− return $ Lambda noLoc [PVar pvarName] body
126+ body <- expr $ f $ return $ Expression $ Var $ UnQual pvarName
127+ return $ Expression $ Lambda noLoc [PVar pvarName] $ runExpression body
128128
129129--------------------------------------------------------------------------------
130130-- Apply functions
131131
132+
132133-- | Apply a function in a haskell expression to a value.
133134applyE :: ExpG (a -> b) -> ExpG a -> ExpG b
134−applyE a b = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b]
135− where ce = unsafeCoerceE
135+applyE a b = wrap $ liftM (foldl1 App) $ sequence [unwrap a, unwrap b]
136+ where wrap = fmap Expression
137+ unwrap = fmap runExpression
138+
136139
137140-- | Operator for 'applyE'.
138141(<>$) :: ExpG (a -> b) -> ExpG a -> ExpG b
@@ -142,28 +145,33 @@ infixl 1 <>$
142145
143146-- | ApplyE for 2 arguments
144147applyE2 :: 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
148+applyE2 a b c = wrap $ liftM (foldl1 App) $ sequence [unwrap a,unwrap b,unwrap c]
149+ where wrap = fmap Expression
150+ unwrap = fmap runExpression
147151
148152-- | Apply a function to 3 arguments
149153applyE3 :: 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
154+applyE3 a b c d = wrap $ liftM (foldl1 App) $ sequence [unwrap a,unwrap b,unwrap c,unwrap d]
155+ where wrap = fmap Expression
156+ unwrap = fmap runExpression
152157
153158-- | Apply a function to 4 arguments
154159applyE4 :: 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
160+applyE4 a b c d e = wrap $ liftM (foldl1 App) $ sequence [unwrap a,unwrap b,unwrap c,unwrap d,unwrap e]
161+ where wrap = fmap Expression
162+ unwrap = fmap runExpression
157163
158164-- | Apply a function to 5 arguments
159165applyE5 :: 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
166+applyE5 a b c d e f = wrap $ liftM (foldl1 App) $ sequence [unwrap a,unwrap b,unwrap c,unwrap d,unwrap e,unwrap f]
167+ where wrap = fmap Expression
168+ unwrap = fmap runExpression
162169
163170-- | Apply a function to 6 arguments
164171applyE6 :: 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
172+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]
173+ where wrap = fmap Expression
174+ unwrap = fmap runExpression
167175
168176--------------------------------------------------------------------------------
169177-- Generate modules
@@ -180,7 +188,7 @@ data FunRef t = FunRef Name
180188
181189instance GenExp (FunRef t) where
182190 type GenExpType (FunRef t) = t
183− expr (FunRef n) = return $ Var $ UnQual n
191+ expr (FunRef n) = return $ Expression $ Var $ UnQual n
184192
185193-- | Generate a ExportSpec for a given function item.
186194exportFun :: FunRef t -> ExportSpec
@@ -189,8 +197,8 @@ exportFun (FunRef name) = EVar (UnQual name)
189197-- | 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.
190198addDecl :: Name -> ExpG t -> ModuleM (FunRef t)
191199addDecl name e = ModuleM $ do
192− let (body, mods) = runExpM e
193− tell (mods, [FunBind [Match noLoc name [] Nothing (UnGuardedRhs body) $ BDecls []]])
200+ let (body, mods) = runGenerate e
201+ tell (mods, [FunBind [Match noLoc name [] Nothing (UnGuardedRhs $ runExpression body) $ BDecls []]])
194202 return $ FunRef name
195203
196204-- | Extract the Module from a module generator.