module Language.Haskell.Generate.Base
( ExpM(..), ExpG, ExpType
, runExpM, newName
, useValue, useCon, useVar
, caseE
, applyE, applyE2, applyE3, applyE4, applyE5, applyE6
, (<>$)
, GenExp(..)
, ModuleM(..)
, ModuleG
, FunRef(..)
, Name(..)
, exportFun
, addDecl
, runModuleM
, generateModule
)
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
newtype ExpM t a = ExpM { unExpM :: StateT Integer (Writer (S.Set ModuleName)) a } deriving (Functor, Applicative, Monad)
type ExpG t = ExpM t Exp
runExpM :: ExpM t a -> (a, S.Set ModuleName)
runExpM (ExpM expt) = runWriter $ evalStateT expt 0
unsafeCoerceE :: ExpM t a -> ExpM t' a
unsafeCoerceE (ExpM x) = ExpM x
caseE :: ExpG x -> [(Pat, ExpG t)] -> ExpG t
caseE v alt = do
v' <- unsafeCoerceE v
alt' <- mapM (\(p,a) -> fmap (\a' -> Alt noLoc p (UnGuardedAlt a') (BDecls [])) a) alt
return $ Case v' alt'
useValue :: String -> Name -> ExpG a
useValue md name = ExpM $ do
lift $ tell $ S.singleton $ ModuleName md
return $ Var $ Qual (ModuleName md) name
useCon :: String -> Name -> ExpM t QName
useCon md name = ExpM $ do
lift $ tell $ S.singleton $ ModuleName md
return $ Qual (ModuleName md) name
useVar :: Name -> ExpG t
useVar name = return $ Var $ UnQual name
newName :: String -> ExpM t Name
newName pref = ExpM $ do
i <- get <* modify succ
return $ Ident $ pref ++ show i
type family ExpType a :: *
type instance ExpType (ExpM t a) = t
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 Char where
type GenExpType Char = Char
expr = return . Lit . Char
instance GenExp Integer where
type GenExpType Integer = Integer
expr = return . Lit . Int
instance GenExp Rational where
type GenExpType Rational = Rational
expr = return . Lit . Frac
instance GenExp a => GenExp [a] where
type GenExpType [a] = [GenExpType a]
expr = ExpM . fmap List . mapM (unExpM . expr)
instance GenExp x => GenExp (ExpG a -> x) where
type GenExpType (ExpG a -> x) = a -> GenExpType x
expr f = do
pvarName <- newName "pvar_"
body <- unsafeCoerceE $ expr $ f $ return $ Var $ UnQual pvarName
return $ Lambda noLoc [PVar pvarName] body
applyE :: ExpG (a -> b) -> ExpG a -> ExpG b
applyE a b = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b]
where ce = unsafeCoerceE
(<>$) :: 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 = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c]
where ce = unsafeCoerceE
applyE3 :: ExpG (a -> b -> c -> d) -> ExpG a -> ExpG b -> ExpG c -> ExpG d
applyE3 a b c d = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c,ce d]
where ce = unsafeCoerceE
applyE4 :: ExpG (a -> b -> c -> d -> e) -> ExpG a -> ExpG b -> ExpG c -> ExpG d -> ExpG e
applyE4 a b c d e = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c,ce d,ce e]
where ce = unsafeCoerceE
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 = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c,ce d,ce e,ce f]
where ce = unsafeCoerceE
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 = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c,ce d,ce e,ce f,ce g]
where ce = unsafeCoerceE
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 $ 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) = runExpM e
tell (mods, [FunBind [Match noLoc name [] Nothing (UnGuardedRhs 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