module Agda.Compiler.Alonzo.Haskell where
import Language.Haskell.Syntax
import Language.Haskell.Pretty
import System.IO
dummyLoc :: SrcLoc
dummyLoc = SrcLoc "=alonzo=" 0 0
hsModule :: String -> [HsDecl] -> HsModule
hsModule name decls = HsModule dummyLoc (Module name) Nothing [] decls
hsModuleImporting :: String -> [String] -> [String] -> [HsDecl] -> HsModule
hsModuleImporting name imps qimps decls =
HsModule dummyLoc (Module name) Nothing
(map hsImport imps ++ impRTS : impRTP : map hsQImport qimps) decls
hsImport :: String -> HsImportDecl
hsImport s = HsImportDecl dummyLoc (Module s) False Nothing Nothing
hsQImport :: String -> HsImportDecl
hsQImport s = HsImportDecl dummyLoc (Module s) True Nothing Nothing
impRTS :: HsImportDecl
impRTS = hsImport "RTS"
impRTP :: HsImportDecl
impRTP = hsQImport "RTP"
hsUndefined :: HsExp
hsUndefined = hsVar "undefined"
hsError :: String -> HsExp
hsError s = HsApp (hsVar "error") (HsLit $ HsString s)
hsCast e@(HsVar _) = HsApp (hsVar "cast") e
hsCast e@(HsCon _) = HsApp (hsVar "cast") e
hsCast e = HsApp (hsVar "cast") (HsParen e)
hsVar :: String -> HsExp
hsVar s = HsVar $ UnQual $ HsIdent s
hsCon :: String -> HsExp
hsCon s = HsCon $ UnQual $ HsIdent s
hsLam :: String -> HsExp -> HsExp
hsLam n e = HsLambda dummyLoc [HsPVar (HsIdent n)] e
hsAp :: HsExp -> HsExp -> HsExp
hsAp e1 e2 = HsApp (hsCast e1) $ HsParen (hsCast e2)
outputHsModule s hsmod numOfMainS = do
handle <- openFile (s++".hs") WriteMode
printHsModule handle hsmod
case numOfMainS of
Nothing -> return ()
Just i -> printHsMain handle i
hClose handle
printHsMain handle i = do
hPutStrLn handle mainStr where
mainStr = "main = d" ++ show i
printHsModule :: Handle -> HsModule -> IO ()
printHsModule handle hsmod = do
hPutStrLn handle "{-# OPTIONS -fglasgow-exts #-}"
hPutStrLn handle ""
hPutStrLn handle "-- Generated by Alonzo"
hPutStrLn handle ""
hPutStrLn handle $ prettyPrint $ hsmod
printHsDecls :: [HsDecl] -> IO ()
printHsDecls ds = mapM_ (putStrLn . prettyPrint) ds
data AlDecl = AlDecl [HsDecl] | AlComment String
printAlDecl :: AlDecl -> IO()
printAlDecl (AlDecl ds) = printHsDecls ds
printAlDecl (AlComment s) = putStrLn $ "{- "++s++" -}"
printAlModule :: String -> [AlDecl] -> IO()
printAlModule name ds = do
putStrLn "{-# OPTIONS -fglasgow-exts -cpp #-}"
putStrLn ""
putStrLn "-- Generated by Alonzo"
putStrLn ""
putStrLn $ "module " ++ name ++ " where"
putStrLn "import RTS"
mapM_ printAlDecl ds
hsTypedExp :: HsQName -> HsExp -> HsExp
hsTypedExp qn e = HsExpTypeSig dummyLoc e $ HsQualType [] $ HsTyCon qn
hsPreludeName :: String -> HsQName
hsPreludeName s = Qual prelude_mod $ HsIdent s
hsPreludeTypedExp :: String -> HsExp -> HsExp
hsPreludeTypedExp s e = hsTypedExp (hsPreludeName s) e