@@ -0,0 +1,204 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE UndecidableInstances #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+module Language.Haskell.Generate.Base
7+ ( ExpM(..), ExpG, ExpType
8+ , runExpM, newName
9+ , useValue, useCon, useVar
10+ , caseE
11+ , applyE, applyE2, applyE3, applyE4, applyE5, applyE6
12+ , (<>$)
13+ , GenExp(..)
14+ , ModuleM(..)
15+ , ModuleG
16+ , FunRef(..)
17+ , Name(..)
18+ , exportFun
19+ , addDecl
20+ , runModuleM
21+ , generateModule
22+ )
23+ where
24+
25+import Control.Applicative
26+import Control.Monad
27+import Control.Monad.Trans.Class
28+import Control.Monad.Trans.State
29+import Control.Monad.Trans.Writer
30+import qualified Data.Set as S
31+import Language.Haskell.Exts.Pretty
32+import Language.Haskell.Exts.SrcLoc
33+import Language.Haskell.Exts.Syntax
34+
35+--------------------------------------------------------------------------------
36+-- Generate expressions
37+
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)
42+
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
46+
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
50+
51+unsafeCoerceE :: ExpM t a -> ExpM t' a
52+unsafeCoerceE (ExpM x) = ExpM x
53+
54+-- | Generate a case expression.
55+caseE :: ExpG x -> [(Pat, ExpG t)] -> ExpG t
56+caseE 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'
60+
61+-- | Import a function from a module. This function is polymorphic in the type of the resulting expression,
62+-- you should probably only use this function to define type-restricted specializations.
63+--
64+-- Example:
65+--
66+-- > addInt :: ExpG (Int -> Int -> Int) -- Here we restricted the type to something sensible
67+-- > addInt = useValue "Prelude" $ Symbol "+"
68+--
69+useValue :: String -> Name -> ExpG a
70+useValue md name = ExpM $ do
71+ lift $ tell $ S.singleton $ ModuleName md
72+ return $ Var $ Qual (ModuleName md) name
73+
74+-- | 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
77+ lift $ tell $ S.singleton $ ModuleName md
78+ return $ Qual (ModuleName md) name
79+
80+-- | Use the value of a variable with the given name.
81+useVar :: Name -> ExpG t
82+useVar name = return $ Var $ UnQual name
83+
84+-- | Generate a new unique variable name with the given prefix. Note that this new variable name
85+-- is only unique relative to other variable names generated by this function.
86+newName :: String -> ExpM t Name
87+newName pref = ExpM $ do
88+ i <- get <* modify succ
89+ return $ Ident $ pref ++ show i
90+
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.
96+class GenExp t where
97+ type GenExpType t :: *
98+
99+ -- | This function generates the haskell expression from the given haskell value.
100+ expr :: t -> ExpG (GenExpType t)
101+
102+instance GenExp (ExpG a) where
103+ type GenExpType (ExpG a) = a
104+ expr = id
105+
106+instance GenExp Char where
107+ type GenExpType Char = Char
108+ expr = return . Lit . Char
109+
110+instance GenExp Integer where
111+ type GenExpType Integer = Integer
112+ expr = return . Lit . Int
113+
114+instance GenExp Rational where
115+ type GenExpType Rational = Rational
116+ expr = return . Lit . Frac
117+
118+instance GenExp a => GenExp [a] where
119+ type GenExpType [a] = [GenExpType a]
120+ expr = ExpM . fmap List . mapM (unExpM . expr)
121+
122+instance GenExp x => GenExp (ExpG a -> x) where
123+ type GenExpType (ExpG a -> x) = a -> GenExpType x
124+ expr f = do
125+ pvarName <- newName "pvar_"
126+ body <- unsafeCoerceE $ expr $ f $ return $ Var $ UnQual pvarName
127+ return $ Lambda noLoc [PVar pvarName] body
128+
129+--------------------------------------------------------------------------------
130+-- Apply functions
131+
132+-- | Apply a function in a haskell expression to a value.
133+applyE :: ExpG (a -> b) -> ExpG a -> ExpG b
134+applyE a b = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b]
135+ where ce = unsafeCoerceE
136+
137+-- | Operator for 'applyE'.
138+(<>$) :: ExpG (a -> b) -> ExpG a -> ExpG b
139+(<>$) = applyE
140+
141+infixl 1 <>$
142+
143+-- | ApplyE for 2 arguments
144+applyE2 :: 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
147+
148+-- | Apply a function to 3 arguments
149+applyE3 :: 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
152+
153+-- | Apply a function to 4 arguments
154+applyE4 :: 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
157+
158+-- | Apply a function to 5 arguments
159+applyE5 :: 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
162+
163+-- | Apply a function to 6 arguments
164+applyE6 :: 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
167+
168+--------------------------------------------------------------------------------
169+-- Generate modules
170+
171+-- | A module keeps track of the needed imports, but also has a list of declarations in it.
172+newtype ModuleM a = ModuleM (Writer (S.Set ModuleName, [Decl]) a) deriving (Functor, Applicative, Monad)
173+
174+-- | This is the resulting type of a function generating a module. It is a ModuleM action returning the export list.
175+type ModuleG = ModuleM (Maybe [ExportSpec])
176+
177+-- | A reference to a function. With a reference to a function, you can apply it (by lifting it into ExprT using 'expr') to some value
178+-- or export it using 'exportFun'.
179+data FunRef t = FunRef Name
180+
181+instance GenExp (FunRef t) where
182+ type GenExpType (FunRef t) = t
183+ expr (FunRef n) = return $ Var $ UnQual n
184+
185+-- | Generate a ExportSpec for a given function item.
186+exportFun :: FunRef t -> ExportSpec
187+exportFun (FunRef name) = EVar (UnQual name)
188+
189+-- | 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.
190+addDecl :: Name -> ExpG t -> ModuleM (FunRef t)
191+addDecl name e = ModuleM $ do
192+ let (body, mods) = runExpM e
193+ tell (mods, [FunBind [Match noLoc name [] Nothing (UnGuardedRhs body) $ BDecls []]])
194+ return $ FunRef name
195+
196+-- | Extract the Module from a module generator.
197+runModuleM :: ModuleG -> String -> Module
198+runModuleM (ModuleM act) name =
199+ Module noLoc (ModuleName name) [] Nothing export (map (\md -> ImportDecl noLoc md True False Nothing Nothing Nothing) $ S.toList imps) decls
200+ where (export, (imps, decls)) = runWriter act
201+
202+-- | Generate the source code for a module.
203+generateModule :: ModuleG -> String -> String
204+generateModule = fmap prettyPrint . runModuleM