module Language.Haskell.Generate.Monad
( Generate(..), ExpG
, runGenerate, newName
, returnE
, useValue, useCon, useVar
, caseE
, applyE, applyE2, applyE3, applyE4, applyE5, applyE6
, (<>$)
, GenExp(..)
, ModuleM(..)
, ModuleG
, FunRef(..)
, Name(..)
, exportFun
, addDecl
, runModuleM
, generateModule
, generateExp
)
where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Control.Monad.Trans.Writer
import qualified Data.Set as S
import Language.Haskell.Exts.Pretty
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.Exts.Syntax
import Language.Haskell.Generate.Expression
newtype Generate a = Generate { unGenerate :: StateT Integer (Writer (S.Set ModuleName)) a } deriving (Functor, Applicative, Monad)
runGenerate :: Generate a -> (a, S.Set ModuleName)
runGenerate (Generate a) = runWriter $ evalStateT a 0
type ExpG t = Generate (Expression t)
returnE :: Exp -> ExpG t
returnE = return . Expression
generateExp :: ExpG t -> String
generateExp = prettyPrint . runExpression . fst . runGenerate
caseE :: ExpG x -> [(Pat, ExpG t)] -> ExpG t
caseE v alt = do
v' <- v
alt' <- mapM (\(p,a) -> fmap (\a' -> Alt noLoc p (UnGuardedAlt $ runExpression a') (BDecls [])) a) alt
return $ Expression $ Case (runExpression v') alt'
useValue :: String -> Name -> ExpG a
useValue md name = Generate $ do
lift $ tell $ S.singleton $ ModuleName md
return $ Expression $ Var $ Qual (ModuleName md) name
useCon :: String -> Name -> Generate QName
useCon md name = Generate $ do
lift $ tell $ S.singleton $ ModuleName md
return $ Qual (ModuleName md) name
useVar :: Name -> ExpG t
useVar name = return $ Expression $ Var $ UnQual name
newName :: String -> Generate Name
newName pref = Generate $ do
i <- get <* modify succ
return $ Ident $ pref ++ show i
class GenExp t where
type GenExpType t :: *
expr :: t -> ExpG (GenExpType t)
instance GenExp (ExpG a) where
type GenExpType (ExpG a) = a
expr = id
instance GenExp (Expression t) where
type GenExpType (Expression t) = t
expr = return
instance GenExp Char where
type GenExpType Char = Char
expr = return . Expression . Lit . Char
instance GenExp Integer where
type GenExpType Integer = Integer
expr = return . Expression . Lit . Int
instance GenExp Rational where
type GenExpType Rational = Rational
expr = return . Expression . Lit . Frac
instance GenExp a => GenExp [a] where
type GenExpType [a] = [GenExpType a]
expr = Generate . fmap (Expression . List . map runExpression) . mapM (unGenerate . expr)
instance GenExp x => GenExp (ExpG a -> x) where
type GenExpType (ExpG a -> x) = a -> GenExpType x
expr f = do
pvarName <- newName "pvar_"
body <- expr $ f $ return $ Expression $ Var $ UnQual pvarName
return $ Expression $ Lambda noLoc [PVar pvarName] $ runExpression body
applyE :: ExpG (a -> b) -> ExpG a -> ExpG b
applyE a b = wrap $ liftM (foldl1 App) $ sequence [unwrap a, unwrap b]
where wrap = fmap Expression
unwrap = fmap runExpression
(<>$) :: ExpG (a -> b) -> ExpG a -> ExpG b
(<>$) = applyE
infixl 1 <>$
applyE2 :: ExpG (a -> b -> c) -> ExpG a -> ExpG b -> ExpG c
applyE2 a b c = wrap $ liftM (foldl1 App) $ sequence [unwrap a,unwrap b,unwrap c]
where wrap = fmap Expression
unwrap = fmap runExpression
applyE3 :: ExpG (a -> b -> c -> d) -> ExpG a -> ExpG b -> ExpG c -> ExpG d
applyE3 a b c d = wrap $ liftM (foldl1 App) $ sequence [unwrap a,unwrap b,unwrap c,unwrap d]
where wrap = fmap Expression
unwrap = fmap runExpression
applyE4 :: ExpG (a -> b -> c -> d -> e) -> ExpG a -> ExpG b -> ExpG c -> ExpG d -> ExpG e
applyE4 a b c d e = wrap $ liftM (foldl1 App) $ sequence [unwrap a,unwrap b,unwrap c,unwrap d,unwrap e]
where wrap = fmap Expression
unwrap = fmap runExpression
applyE5 :: ExpG (a -> b -> c -> d -> e -> f) -> ExpG a -> ExpG b -> ExpG c -> ExpG d -> ExpG e -> ExpG f
applyE5 a b c d e f = wrap $ liftM (foldl1 App) $ sequence [unwrap a,unwrap b,unwrap c,unwrap d,unwrap e,unwrap f]
where wrap = fmap Expression
unwrap = fmap runExpression
applyE6 :: ExpG (a -> b -> c -> d -> e -> f -> g) -> ExpG a -> ExpG b -> ExpG c -> ExpG d -> ExpG e -> ExpG f -> ExpG g
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]
where wrap = fmap Expression
unwrap = fmap runExpression
newtype ModuleM a = ModuleM (Writer (S.Set ModuleName, [Decl]) a) deriving (Functor, Applicative, Monad)
type ModuleG = ModuleM (Maybe [ExportSpec])
data FunRef t = FunRef Name
instance GenExp (FunRef t) where
type GenExpType (FunRef t) = t
expr (FunRef n) = return $ Expression $ Var $ UnQual n
exportFun :: FunRef t -> ExportSpec
exportFun (FunRef name) = EVar (UnQual name)
addDecl :: Name -> ExpG t -> ModuleM (FunRef t)
addDecl name e = ModuleM $ do
let (body, mods) = runGenerate e
tell (mods, [FunBind [Match noLoc name [] Nothing (UnGuardedRhs $ runExpression body) $ BDecls []]])
return $ FunRef name
runModuleM :: ModuleG -> String -> Module
runModuleM (ModuleM act) name =
Module noLoc (ModuleName name) [] Nothing export (map (\md -> ImportDecl noLoc md True False Nothing Nothing Nothing) $ S.toList imps) decls
where (export, (imps, decls)) = runWriter act
generateModule :: ModuleG -> String -> String
generateModule = fmap prettyPrint . runModuleM