>
>
> 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 :: 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)
>
>
>
> 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; }
>
> 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] )
>
>
>
>
>
>
> 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)"
>
> 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
>
>
>
> convert lVars envVars = LamE [TupP [TupP (map VarP lVars),
> TupP ((map VarP envVars) ++ [TupP []])]] (projExp (map VarE (lVars ++ envVars)))
>
>
> 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)))
>
>
> | showName n == "_reserved_codo_block_marker_" = codoMain (LamE [VarP v] (DoE stmts))
>
> | otherwise = return $ (DoE ((NoBindS (VarE n)):stmts))
> doToCodo e = return e
>
>
>
>
> envProj :: [Name] -> ExpQ -> ExpQ
> envProj vars exp = let gam = mkName "gamma" in (lamE [varP gam] (letE (projs vars (varE gam)) exp))
>
> mkProj gam (v, n) = valD (varP v) (normalB [| fmap $(prj n) $(gam) |]) []
>
> projs :: [Name] -> ExpQ -> [DecQ]
> projs x gam = map (mkProj gam) (zip x [0..(length x 1)])
>
> prj 0 = [| fst |]
> prj n = [| $(prj (n1)) . snd |]