{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}
module Pugs.Compile.Pugs (genPugs) where
import Pugs.AST
import Pugs.Types
import Pugs.Internals
import qualified UTF8 as Str
import qualified Data.Map as Map
type Str = Str.ByteString
type Comp a = WriterT [a] Eval a
class (Show x) => Compile x where
compile :: x -> Comp Str
compile x = fail ("Unrecognized construct: " ++ show x)
compileList :: [x] -> Comp Str
compileList xs = do
xsC <- mapM compile xs
return $ Str.concat [bl, joinMany xsC, br]
joinMany :: [Str] -> Str
joinMany xs = Str.join cm (filter (not . Str.null) xs)
instance (Compile x) => Compile [x] where
compile = compileList
instance Compile (Maybe Exp) where
compile Nothing = return $ Str.pack "Nothing"
compile (Just exp) = compWith "Just" [compile exp]
pl, pr, bl, br, cm :: Str
pl = Str.pack "("
pr = Str.pack ")"
bl = Str.pack "["
br = Str.pack "]"
cm = Str.pack ", "
ret :: String -> Comp Str
ret = return . Str.pack
compWith :: String -> [Comp Str] -> Comp Str
compWith con xs = do
xsC <- sequence xs
return $ Str.concat [pl, Str.unwords (Str.pack con:concatMap (\x -> [pl, x, pr]) xsC), pr]
instance Compile Exp where
compile (App exp1 exp2 exps) = do
compWith "App" [compile exp1, compile exp2, compile exps]
compile (Syn syn exps) = do
compWith "Syn" [ret (show syn), compile exps]
compile (Ann ann exp) = do
compWith "Ann" [ret (show ann), compile exp]
compile (Pad scope pad exp) = do
compWith "Pad" [ret (show scope), compile pad, compile exp]
compile (Stmts exp1 exp2) = do
compWith "Stmts" [compile exp1, compile exp2]
compile (Val val) = do
compWith "Val" [compile val]
compile exp = ret $ "(" ++ show exp ++ ")"
instance Compile Pad where
compile pad = do
symsC <- mapM compile syms
return $ Str.concat [Str.pack "(mkPad [", joinMany symsC, Str.pack "])"]
where
syms = padToList pad
instance Compile IHash where
compile map = error (show map)
instance Compile (Var, [(TVar Bool, TVar VRef)]) where
compile (var, tvars)
| SType <- v_sigil var, isGlobalVar var = return Str.empty
| otherwise = do
tvarsC <- fmap (filter (not . Str.null)) $ mapM compile tvars
if null tvarsC then return Str.empty else do
return $ Str.concat [pl, Str.pack (cast var), Str.pack ", [", joinMany tvarsC, br, pr]
instance (Typeable a) => Compile (Maybe (TVar a)) where
compile = const . ret $ "Nothing"
instance Compile (TVar Bool, TVar VRef) where
compile (fresh, tvar) = do
tvarC <- compile tvar
if Str.null tvarC then return Str.empty else do
freshC <- compile fresh
return $ Str.concat [pl, freshC, cm, tvarC, pr]
instance Compile Bool where
compile bool = ret $ "(" ++ show bool ++ ")"
instance Compile a => Compile (Map VStr a) where
compile map | Map.null map = ret $ "(Map.empty)"
compile map = error (show map)
instance Compile (IVar VScalar) where
compile iv = do
val <- lift $ readIVar iv
valC <- compile val
return $ Str.concat [Str.pack "(newScalar ", valC, pr]
instance (Typeable a, Compile a) => Compile (TVar a) where
compile fresh = do
vref <- liftIO $ atomically (readTVar fresh)
vrefC <- compile vref
if Str.null vrefC then return Str.empty else do
tv <- liftIO $ fmap (Str.pack . ('t':) . show . hashUnique) newUnique
tell [Str.concat [tv, Str.pack " <- liftSTM (newTVar ", vrefC, Str.pack ");\n"]]
return tv
instance Compile VRef where
compile (MkRef (ICode cv)) = do
vsub <- lift $ code_fetch cv
vsubC <- compile vsub
if Str.null vsubC then return Str.empty else do
return $ Str.concat [Str.pack "(MkRef (ICode ", vsubC, pr, pr]
compile (MkRef (IScalar sv)) | scalar_iType sv == mkType "Scalar::Const" = do
sv <- lift $ scalar_fetch sv
svC <- compile sv
if Str.null svC then return Str.empty else do
return $ Str.concat [Str.pack "(MkRef (IScalar ", svC, pr, pr]
compile ref = do
objc <- liftIO $ fmap (Str.pack . ('o':) . show . hashUnique) newUnique
tell [Str.append objc (Str.pack (" <- newObject (mkType \"" ++ showType (refType ref) ++ "\");\n"))]
return objc
instance Compile Val where
compile (VCode code) = do
compWith "VCode" [compile code]
compile (VObject obj) = do
compWith "VObject" [compile obj]
compile val = ret $ "(" ++ show val ++ ")"
instance Compile VObject where
compile (MkObject typ attrs Nothing _) = do
attrsC <- compile attrs
uniq <- liftIO $ fmap (Str.pack . ('u':) . show . hashUnique) newUnique
tell [Str.append uniq (Str.pack " <- liftIO newUnique;\n")]
return $ Str.unwords [pl, Str.pack "MkObject", Str.pack (show typ), attrsC, Str.pack "Nothing", uniq, pr]
compile obj = fail $ "Cannot compile Object of Dynamic type: " ++ show obj
-- Haddock can't cope with Template Haskell
instance Compile VCode where
-- compile MkCode{ subBody = Prim _ } = return $ text "return mkPrim"
compile MkCode{ subBody = Prim _ } = return Str.empty
-- XXX - Ew. This signature can't be right.
compile (MkCode v1 v2 v3 _ v4 v5 v6 v7 v8 v9 v10 _ _ _ _ _ _ _ _ _ _ _ _) = do
compWith "MkCode"
[ compile v1
, ret (show v2)
, ret (show v3)
, ret "Nothing"
, ret (show v4)
, ret (show v5)
, ret (show v6)
, ret (show v7)
, ret (show v8)
, compile v9
, compile v10
, ret "Nothing"
]
genPugs :: Eval Val
genPugs = do
exp <- asks envBody
glob <- askGlobal
(globC, globT) <- runWriterT $ compile glob
(expC, expT) <- runWriterT $ compile exp
return . VStr . unlines $
[ "{-# OPTIONS_GHC -fglasgow-exts -fno-warn-unused-imports -fno-warn-unused-binds #-}"
, "module Main where"
, "import Pugs.Run"
, "import Pugs.AST"
, "import Pugs.Types"
, "import Pugs.Internals"
, "import qualified Data.Map as Map"
, ""
, "main = do"
, " glob <- globC"
, " exp <- expC"
, " runAST glob exp"
, ""
, "globC = do {" ++ Str.unpack (Str.concat globT) ++ "return " ++ Str.unpack globC ++ "}"
, ""
, "expC = do {" ++ Str.unpack (Str.concat expT) ++ "return " ++ Str.unpack expC ++ "}"
, ""
]