codo-notation (empty) → 0.5
raw patch · 4 files changed
+289/−0 lines, 4 filesdep +basedep +comonaddep +haskell-src-metasetup-changed
Dependencies added: base, comonad, haskell-src-meta, parsec, template-haskell, uniplate
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- codo-notation.cabal +64/−0
- src/Language/Haskell/Codo.lhs +193/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ codo-notation.cabal view
@@ -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: <http://www.cl.cam.ac.uk/~dao29/drafts/codo-notation-orchard-ifl12.pdf> with a numer of examples.+ .+ Further examples can be found here: <https://github.com/dorchard/codo-notation>.+ +-- description: +license: BSD3+license-file: LICENSE+author: Dominic Orchard <dom.orchard@gmail.com>+maintainer: Dominic Orchard <dom.orchard@gmail.com>+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
+ src/Language/Haskell/Codo.lhs view
@@ -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 |]