Backend.hs

{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances, KindSignatures #-}

module Forml.Javascript.Backend where
        
        import Forml.Types.Namespace
        import Forml.TypeCheck.Types
        import Forml.Parser.Utils 
        
        import Data.Monoid      
        import Data.String.Utils
        import Text.Parsec (sourceLine)
            
        type TypeSystem = [(Namespace, [Assumption])]
        
        data JSState = JSState { src :: String
                               , assumptions :: TypeSystem }
        
        newtype JS a = JS (JSState -> (JSState, a))
        
        instance Monad JS where
          fail x     = JS (\_ -> error$ x) 
          return x   = JS (\y -> (y, x))
          JS f >>= g = JS (\x -> case f x of
                                  (y, x') -> let JS gx = g x'
                                             in  gx y)
         
        instance Functor JS where
            fmap f y = y >>= (\x -> JS (\x' -> (x', f x)))
        
        class Javascript e t | e -> t where toJS :: e -> JS t
        
        runJS :: String -> JS t -> t
        runJS src (JS f) = snd . f $ JSState src []
        
        instance (Javascript a b, Monoid b) => Javascript [a] b where
        
                toJS []     = return mempty
                toJS (x:xs) = do x'  <- toJS x
                                 xs' <- toJS xs
                                 return $ mappend x' xs'
                                 
        get_error :: Addr a -> String -> String
        get_error (Addr (sourceLine -> x) (sourceLine -> y) _) =
        
             rstrip . unlines . lines . rstrip . unlines . take ((y - x) + 1) . drop (x - 1) . lines