diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Dominic Orchard + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jason Dagit nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/codo-notation.cabal b/codo-notation.cabal new file mode 100644 --- /dev/null +++ b/codo-notation.cabal @@ -0,0 +1,64 @@ +name: codo-notation +version: 0.5 +synopsis: A notation for comonads, analogous to the do-notation for monads. +description: Requires the @TemplateHaskell@ and @QuasiQuotes@ extensions. + . + Example 1: + . + @ + {-\# LANGUAGE TemplateHaskell \#-} + {-\# LANGUAGE QuasiQuotes \#-} + . + import Control.Comonad + import Language.Haskell.Codo + . + foo :: (Comonad c, Num a) => c a -> a + foo = [codo| x => extract x + 1 |] + @ + . + Example 2: + . + @ + import Data.Monoid + + instance Monoid Double where + mempty = 0.0 + mappend = (+) + . + differentiate f = ((f 0.001) - f 0) / 0.001 + . + minima :: (Double -> Double) -> Bool + minima = [codo| f => f' <- differentiate f + f'' <- differentiate f' + (extract f' < 0.001) && (extract f'' > 0) |] + @ + . + Further explanation of the syntax can be found in the following (short) paper: with a numer of examples. + . + Further examples can be found here: . + +-- description: +license: BSD3 +license-file: LICENSE +author: Dominic Orchard +maintainer: Dominic Orchard +stability: experimental +-- copyright: +category: Language +build-type: Simple +cabal-version: >=1.7 + +source-repository head + type: git + location: git://github.com/dorchard/codo-notation.git + +library + exposed-modules: Language.Haskell.Codo + -- other-modules: + build-depends: base >= 4.2 && < 5, + comonad >= 3, + uniplate > 1.6, + template-haskell >= 2.7, + haskell-src-meta >= 0.5.1, + parsec >= 3 + hs-source-dirs: src diff --git a/src/Language/Haskell/Codo.lhs b/src/Language/Haskell/Codo.lhs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Codo.lhs @@ -0,0 +1,193 @@ +> {-# 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 (VarP v) (NormalB e) []]):bs) vars = +> [| (\gamma -> +> $(letE [valD (varP $ v) +> (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 _ _ = 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 |]