codo-notation-0.5.2: src/Language/Haskell/Codo.lhs
> {-# LANGUAGE TemplateHaskell #-}
> {-# LANGUAGE NoMonomorphismRestriction #-}
> module Language.Haskell.Codo(codo) where
> import Text.ParserCombinators.Parsec
> import Text.ParserCombinators.Parsec.Expr
> import Text.Parsec.Char
> import qualified Text.ParserCombinators.Parsec.Token as Token
> import Data.Generics.Uniplate.Data
> import Language.Haskell.TH
> import Language.Haskell.TH.Syntax
> import Language.Haskell.TH.Quote
> import Language.Haskell.Meta.Parse
> import Data.Maybe
> import Debug.Trace
> import Data.Char
> import Control.Comonad
> fv var = varE $ mkName var
> -- Codo translation comprises a (1) parsing/textual-transformation phase
> -- (2) interpretation phase
> -- i). top-level transformation
> -- ii). bindings transformations
> -- iii). expression transformation
> -- *****************************
> -- (1) Parsing/textual-transformation
> -- *****************************
> codo :: QuasiQuoter
> codo = QuasiQuoter { quoteExp = interpretCodo,
> quotePat = undefined,
> quoteType = undefined,
> quoteDec = undefined }
> interpretCodo s = do loc <- location
> let pos = (loc_filename loc,
> fst (loc_start loc),
> 1) -- set to 1 as we add spaces in to account for
> -- the start of the line
> -- the following corrects the text to account for the preceding
> -- Haskell code + quasiquote, to preserve alignment of further lines
> s'' <- return ((take (snd (loc_start loc) - 1) (repeat ' ')) ++ s)
> s''' <- (doParse codoTransPart pos s'')
> case (parseExp s''') of
> Left l -> error l
> Right e -> codoMain e
> doParse :: Monad m => (Parser a) -> (String, Int, Int) -> String -> m a
> doParse parser (file, line, col) input =
> case (runParser p () "" input) of
> Left err -> fail $ show err
> Right x -> return x
> where
> p = do { pos <- getPosition;
> setPosition $
> (flip setSourceName) file $
> (flip setSourceLine) line $
> (flip setSourceColumn) col $ pos;
> x <- parser;
> return x; }
> -- Parsing a codo-block
> pattern = (try ( do string "=>"
> return "" )) <|>
> ( do p <- anyChar
> ps <- pattern
> return $ p:ps )
> codoTransPart = do s1 <- many space
> p <- pattern
> rest <- many (codoTransPart')
> return $ (take (length s1 - 4) (repeat ' '))
> ++ "\\" ++ p ++ "-> do" ++ concat rest
> codoTransPart' = try ( do string "codo"
> s1 <- many space
> p <- pattern
> s3 <- many space
> pos <- getPosition
> col <- return $ sourceColumn pos
> marker <- return $ ("_reserved_codo_block_marker_\n" ++ (take (col - 1) (repeat ' ')))
> return $ "\\" ++ p ++ "->" ++ s1 ++ "do " ++ s3 ++ marker)
> <|> ( do c <- anyChar
> if c=='_' then return "_reserved_gamma_"
> else return [c] )
> -- *****************************
> -- (2) interpretation phase
> -- *****************************
> -- i). top-level transformation
> -- *****************************
> -- Top-level translation
> codoMain :: Exp -> Q Exp
> codoMain (LamE p bs) = [| $(codoMain' (LamE p bs)) . (fmap $(return $ projFun p)) |]
> codoMain' :: Exp -> Q Exp
> codoMain' (LamE [TupP ps] (DoE stms)) = codoBind stms (concatMap patToVarPs ps)
> codoMain' (LamE [WildP] (DoE stms)) = codoBind stms [mkName "_reserved_gamma_"]
> codoMain' (LamE [VarP v] (DoE stms)) = codoBind stms [v]
> codoMain' _ = error codoPatternError
> codoPatternError = "Malformed codo: codo must start with either a variable, wildcard, or tuple pattern (of wildcards or variables)"
> -- create the projection function to arrange the codo-Block parameters into the correct ordder
> patToVarPs :: Pat -> [Name]
> patToVarPs (TupP ps) = concatMap patToVarPs ps
> patToVarPs WildP = [mkName "_reserved_gamma_"]
> patToVarPs (VarP v) = [v]
> patToVarPs _ = error "Only tuple, variable, or wildcard patterns currently allowed"
> projExp [] = TupE []
> projExp (x:xs) = TupE [x, (projExp xs)]
> projFun p = LamE (map replaceWild p) (projExp (map VarE (concatMap patToVarPs p)))
> replaceWild WildP = VarP $ mkName "_reserved_gamma_"
> replaceWild x = x
> -- **********************
> -- ii). bindings transformations
> -- **********************
> convert lVars envVars = LamE [TupP [TupP (map VarP lVars),
> TupP ((map VarP envVars) ++ [TupP []])]] (projExp (map VarE (lVars ++ envVars)))
> -- Note all these functions for making binders take a variable which is the "gamma" variable
> -- Binding interpretation (\vdash_c)
> codoBind :: [Stmt] -> [Name] -> Q Exp
> codoBind [NoBindS e] vars = [| \gamma -> $(envProj vars (transformM (doToCodo) e)) gamma |]
> codoBind [x] vars = error "Codo block must end with an expressions"
> codoBind ((NoBindS e):bs) vars = [| $(codoBind bs vars) .
> (extend (\gamma ->
> ($(envProj vars (transformM (doToCodo) e)) gamma,
> extract gamma))) |]
> codoBind ((LetS [ValD p (NormalB e) []]):bs) vars =
> [| (\gamma ->
> $(letE [valD (return p)
> (normalB $ [| $(envProj vars (transformM (doToCodo) e)) gamma |]) []] [| $(codoBind bs vars) $(fv "gamma") |])) |]
> codoBind ((BindS (VarP v) e):bs) vars = [| $(codoBind bs (v:vars)) .
> (extend (\gamma ->
> ($(envProj vars (transformM (doToCodo) e)) gamma,
> extract gamma))) |]
> codoBind ((BindS (TupP ps) e):bs) vars = [| $(codoBind bs ((concatMap patToVarPs ps) ++ vars)) .
> (extend (\gamma ->
> $(return $ convert (concatMap patToVarPs ps) vars)
> ($(envProj vars (transformM (doToCodo) e)) gamma,
> extract gamma))) |]
> codoBind t _ = error "Ill-formed codo bindings"
> doToCodo :: Exp -> Q Exp
> doToCodo (LamE [VarP v] (DoE ((NoBindS (VarE n)):stmts)))
> -- Nested codo-block
> -- notably, doesn't pick up outside environment
> | showName n == "_reserved_codo_block_marker_" = codoMain (LamE [VarP v] (DoE stmts))
>
> | otherwise = return $ (DoE ((NoBindS (VarE n)):stmts))
> doToCodo e = return e
> -- ***********************
> -- iii). expression transformation
> -- ***********************
> -- Creates a scope where all the local variables are project
> envProj :: [Name] -> ExpQ -> ExpQ
> envProj vars exp = let gam = mkName "gamma" in (lamE [varP gam] (letE (projs vars (varE gam)) exp))
> -- Make a comonadic projection
> mkProj gam (v, n) = valD (varP v) (normalB [| fmap $(prj n) $(gam) |]) []
> -- Creates a list of projections
> projs :: [Name] -> ExpQ -> [DecQ]
> projs x gam = map (mkProj gam) (zip x [0..(length x - 1)])
> -- Computes the correct projection
> prj 0 = [| fst |]
> prj n = [| $(prj (n-1)) . snd |]