Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Skeleton of Core compilation.

  • Loading branch information...
commit 978115557311fb5452a892aa6c5fec4f3633c609 1 parent 6b58c4b
@chrisdone chrisdone authored
View
33 src/Data/Generics/Text/Extra.hs
@@ -0,0 +1,33 @@
+module Data.Generics.Text.Extra where
+
+import Data.Data
+import Data.Generics.Aliases
+
+gshow :: Data a => a -> String
+gshow x = gshows x ""
+
+gshows :: Data a => a -> ShowS
+gshows = render `extQ` (shows :: String -> ShowS) where
+ render t
+ | isTuple = showChar '('
+ . drop 1
+ . commaSlots
+ . showChar ')'
+ | isNull = showString "[]"
+ | isList = showChar '['
+ . drop 1
+ . listSlots
+ . showChar ']'
+ | otherwise = showChar '('
+ . constructor
+ . slots
+ . showChar ')'
+
+ where constructor = showString . showConstr . toConstr $ t
+ slots = foldr (.) id . gmapQ ((showChar ' ' .) . gshows) $ t
+ commaSlots = foldr (.) id . gmapQ ((showChar ',' .) . gshows) $ t
+ listSlots = foldr (.) id . init . gmapQ ((showChar ',' .) . gshows) $ t
+
+ isTuple = all (==',') (filter (not . flip elem "()") (constructor ""))
+ isNull = null (filter (not . flip elem "[]") (constructor ""))
+ isList = constructor "" == "(:)"
View
2  src/Language/Fay.hs
@@ -1223,5 +1223,3 @@ parseResult fail ok result =
-- | Get a config option.
config :: (CompileConfig -> a) -> Compile a
config f = gets (f . stateConfig)
-
-instance IsString Name where fromString = Ident
View
105 src/Language/Fay/Core.hs
@@ -0,0 +1,105 @@
+-- | Experimental compilation via System FC.
+
+module Language.Fay.Core where
+
+import Control.Monad
+import Control.Monad.Identity
+import Data.Generics.Text.Extra
+import Data.String
+import Language.Core.Core
+import Language.Core.ParseGlue
+import Language.Core.Parser
+import Language.Fay.Print ()
+import Language.Fay.Types (JsExp(..),JsStmt(..),JsName,printJS)
+import Prelude hiding (exp)
+import System.Process.Extra
+
+type Compile = Identity
+
+-- | Compile the given Haskell file.
+compileFile :: FilePath -> IO [JsStmt]
+compileFile fp = do
+ ast <- getCoreAst fp
+ return (runIdentity (compileModule ast))
+
+-- | Print the JS compiled from a file.
+printCompileFile :: FilePath -> IO ()
+printCompileFile fp = do
+ js <- compileFile fp
+ putStrLn $ printJS $ js
+
+-- | Get the core AST of a Haskell file.
+getCoreAst :: FilePath -> IO Module
+getCoreAst fp = do
+ string <- getCoreString fp
+ case parse string 0 of
+ FailP err -> error err
+ OkP m -> return m
+
+-- | Get the core AST of a Haskell file.
+printCoreAstPretty :: FilePath -> IO ()
+printCoreAstPretty = getCoreAst >=> putStrLn . gshow
+
+-- | Get the ghc -fext-core output of a Haskell file.
+getCoreString :: FilePath -> IO String
+getCoreString fp = do
+ result <- readAllFromProcess' "ghc" [fp,"-v0","-fext-core"] ""
+ case result of
+ Left err -> error err
+ Right (_,_) -> readFile (reverse (dropWhile (/='.') (reverse fp)) ++ "hcr")
+
+-- | Compile a module.
+compileModule :: Module -> Compile [JsStmt]
+compileModule (Module name types vals) = do
+ typeDecls <- fmap concat (mapM compileType types)
+ valDecls <- fmap concat (mapM compileVal vals)
+ return [JsVar (fromString (show name))
+ (JsFun [] (typeDecls ++ valDecls) Nothing)]
+
+-- | Compile a type declaration.
+compileType :: Tdef -> Compile [JsStmt]
+compileType _ = return []
+
+-- | Compile a value declaration.
+compileVal :: Vdefg -> Compile [JsStmt]
+compileVal val =
+ case val of
+ Nonrec vdef -> compileDef vdef
+ _ -> return []
+
+-- | Compile a non-recursive value definition.
+compileDef :: Vdef -> Compile [JsStmt]
+compileDef (Vdef (var,typ,exp)) = do
+ e <- compileExp exp
+ return [JsVar (fromString (qualToString var)) e]
+
+-- | Convert a qualified thing to a name.
+qualToName :: Qual String -> JsName
+qualToName = fromString . qualToString
+
+-- | Convert a qualified thing to a string.
+qualToString :: Qual String -> String
+qualToString (name,var) =
+ show name ++ "." ++ var
+
+-- | Compile an expression.
+compileExp :: Exp -> Compile JsExp
+compileExp exp =
+ case exp of
+ Var qvar -> return (JsName (qualToName qvar))
+ Dcon qcon -> return (JsName (qualToName qcon))
+ Lit lit -> compileLit lit
+ App op arg -> compileApp op arg
+ Appt exp _ -> compileExp exp
+
+-- | Compile a literal.
+compileLit :: Lit -> Compile JsExp
+compileLit lit =
+ return JsNull
+
+-- | Compile a function application.
+compileApp :: Exp -> Exp -> Compile JsExp
+compileApp op arg = do
+ o <- compileExp op
+ a <- compileExp arg
+ return (JsApp o [a])
View
4 src/Language/Fay/Print.hs
@@ -211,7 +211,3 @@ normalize name =
-- | Helpful for writing qualified symbols (Fay.*).
instance IsString ModuleName where
fromString = ModuleName
-
--- | Helpful for writing variable names.
-instance IsString JsName where
- fromString = UnQual . Ident
View
5 src/Language/Fay/Types.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS -fno-warn-orphans #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -22,6 +23,7 @@ module Language.Fay.Types
,FundamentalType(..))
where
+import Data.String
import Control.Applicative
import Control.Exception
import Control.Monad.Error (Error, ErrorT, MonadError)
@@ -206,3 +208,6 @@ data FundamentalType
-- | Unknown.
| UnknownType
deriving (Show,Eq)
+
+instance IsString Name where fromString = Ident
+instance IsString QName where fromString = UnQual . fromString
Please sign in to comment.
Something went wrong with that request. Please try again.