DeepArrow 0.0.1 → 0.2
raw patch · 10 files changed
+562/−141 lines, 10 filesdep +TypeComposedep +haskell-src
Dependencies added: TypeCompose, haskell-src
Files
- CHANGES +20/−2
- DeepArrow.cabal +10/−7
- Makefile +4/−9
- src/Control/Arrow/DeepArrow.hs +75/−38
- src/Control/Arrow/DeepArrow/Examples.hs +5/−3
- src/Data/DDeepArrow.hs +126/−0
- src/Data/FunArr.hs +28/−16
- src/Data/Tupler.hs +0/−66
- src/Language/Haskell/Parens.hs +230/−0
- src/Language/Haskell/ToHs.hs +64/−0
CHANGES view
@@ -1,2 +1,20 @@-Version 0.1.1:-* Changed all files to *nix-style line endings.+% [DeepArrow](http://haskell.org/haskellwiki/DeepArrow) changes++## Version 0.1 ##+++ Removed `Data.Tupler`. Replaced `Pair1` & `Pair2` by `(:*:)` and `(::*::)` in+ `Control.Compose` from [TypeCompose].++ `FunD` and `FunDble`, for convenient Arrow definitions. See also `FunA` &+ `FunAble` in [TypeCompose].++## Version 0.0.2 ##+++ Haddock comments for inpFirst & inpSecond++ Moved the orphan Arrow instance of Pair2 from Control.Arrow.DeepArrow to+ Data.Tupler.++## Version 0.0.1 ##+++ Changed all files to *nix-style line endings.++ [TypeCompose]: http://haskell.org/haskellwiki/TypeCompose
DeepArrow.cabal view
@@ -1,7 +1,7 @@ Name: DeepArrow-Version: 0.0.1+Version: 0.2 Synopsis: Arrows for "deep application"-Category: Composition+Category: Combinators, Control Description: This library provides a framework for type-directed composition of value editors (non-syntactic transformations). The tools enable \"deep function@@ -38,12 +38,15 @@ License: BSD3 Stability: experimental Copyright: (c) 2007 by Conal Elliott+Build-type: Simple Hs-Source-Dirs: src-Build-Depends: base, mtl+Build-Depends: base, mtl, TypeCompose>=0.2, haskell-src Extensions: CPP, UndecidableInstances-Exposed-Modules:+Exposed-Modules: Control.Arrow.DeepArrow- Data.Tupler Data.FunArr- Control.Arrow.DeepArrow.Examples-ghc-options: -O -Wall+ Data.DDeepArrow+ Language.Haskell.ToHs+ Language.Haskell.Parens+ Control.Arrow.DeepArrow.Examples+ghc-options: -Wall
Makefile view
@@ -1,12 +1,7 @@-# See README for Cabal-based building. Other fancy stuff (like haddock) here.--user = conal+# For special configuration, especially for docs. Otherwise see README. -configure_args=--disable-use-packages --haddock-args="\- --read-interface=http://haskell.org/ghc/docs/latest/html/libraries/base,c:/ghc/ghc-6.6/doc/html/libraries/base/base.haddock \- --read-interface=http://haskell.org/ghc/docs/latest/html/libraries/mtl,c:/ghc/ghc-6.6/doc/html/libraries/mtl/mtl.haddock \- $(source_args)\- $(comments_args)\- "+haddock-interfaces=\+ http://haskell.org/ghc/docs/latest/html/libraries/base,c:/ghc/ghc-6.6/doc/html/libraries/base/base.haddock \+ http://haskell.org/ghc/docs/latest/html/libraries/mtl,c:/ghc/ghc-6.6/doc/html/libraries/mtl/mtl.haddock include ../my-cabal-make.inc
src/Control/Arrow/DeepArrow.hs view
@@ -1,10 +1,12 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE TypeOperators #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts #-} ---------------------------------------------------------------------- -- | -- Module : Control.Arrow.DeepArrow -- Copyright : (c) Conal Elliott 2006--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental@@ -23,18 +25,21 @@ , inpF, inpS, inpFirst, inpSecond -- * Misc functions , flipA, unzipA+ -- * 'DeepArrow' instance helper+ , FunDble(..) -- * Some utilities , (->|) ) where import Control.Arrow -import Data.Tupler (Pair2(..))+import Control.Compose ((::*::)(..),inProdd,FunA(..),inFunA, FunAble)+ import Data.FunArr {----------------------------------------------------------- The "deep arrow class"+ The "deep arrow" class ----------------------------------------------------------} {- | @@ -120,15 +125,15 @@ -- | Promote a function extractor into one that reaches into the first -- element of a pair.-funFirst :: DeepArrow (~>) => (d ~> (c->a)) -> ((d, b) ~> (c->(a, b)))+funFirst :: DeepArrow (~>) => (a ~> (d->a')) -> ((a,b) ~> (d->(a',b))) -- | Promote a function extractor into one that reaches into the second -- element of a pair.-funSecond :: DeepArrow (~>) => (d ~> (c->b)) -> ((a, d) ~> (c->(a, b)))+funSecond :: DeepArrow (~>) => (b ~> (d->b')) -> ((a,b) ~> (d->(a,b'))) -- | Promote a function extractor into one that reaches into the result -- element of a function.-funResult :: DeepArrow (~>) => (d ~> (c->b)) -> ((a->d) ~> (c->(a->b)))+funResult :: DeepArrow (~>) => (b ~> (d->b')) -> ((a->b) ~> (d->(a->b'))) funFirst h = first h >>> funF funSecond h = second h >>> funS@@ -148,20 +153,20 @@ inpS = curryA >>> flipA --- Given a way to extract a @d@ input from an @a@ input, leaving an @a'@+-- | Given a way to extract a @d@ input from an @a@ input, leaving an @a'@ -- residual input, 'inpFirst' yields a way to extract a @d@ input from an -- @(a,b)@ input, leaving an @(a',b)@ residual input. inpFirst :: DeepArrow (~>) => (( a ->c) ~> (d -> ( a' ->c))) -> (((a,b)->c) ~> (d -> ((a',b)->c))) --- Analogous to 'inpFirst'.+-- | Analogous to 'inpFirst'. inpSecond :: DeepArrow (~>) => (( b ->c) ~> (d -> ( b' ->c))) -> (((a,b)->c) ~> (d -> ((a,b')->c))) --- See ICFP submission for the derivation of inpFirst and inpSecond+-- See ICFP 07 paper for the derivation of inpFirst and inpSecond inpFirst h = curryA >>> flipA >>> result h >>> flipA >>> result (flipA>>>uncurryA)@@ -204,44 +209,76 @@ lAssocA = arr (\ (a,(b,c)) -> ((a,b),c)) rAssocA = arr (\ ((a,b),c) -> (a,(b,c))) +-- DeepArrow "pairs" are deep arrows --- Arrow "pairs" are arrows-instance (Arrow f, Arrow f') => Arrow (Pair2 f f') where- arr h = Pair2 (arr h , arr h )- Pair2 (f,f') >>> Pair2 (g,g') = Pair2 (f>>>g , f'>>>g' )- first (Pair2 (f,f')) = Pair2 (first f , first f' )- second (Pair2 (f,f')) = Pair2 (second f, second f')- Pair2 (f,f') *** Pair2 (g,g') = Pair2 (f***g , f'***g' )- Pair2 (f,f') &&& Pair2 (g,g') = Pair2 (f&&&g , f'&&&g' )+instance (DeepArrow ar, DeepArrow ar') => DeepArrow (ar ::*:: ar') where+ idA = Prodd (idA, idA)+ dupA = Prodd (dupA, dupA)+ fstA = Prodd (fstA, fstA)+ sndA = Prodd (sndA, sndA)+ funF = Prodd (funF, funF)+ funS = Prodd (funS, funS)+ funR = Prodd (funR, funR)+ curryA = Prodd (curryA, curryA)+ uncurryA = Prodd (uncurryA, uncurryA)+ swapA = Prodd (swapA, swapA)+ lAssocA = Prodd (lAssocA, lAssocA)+ rAssocA = Prodd (rAssocA, rAssocA) --- and DeepArrow "pairs" are deep arrows+ result = inProdd (result *** result)+ -- result (Prodd (f,f')) = Prodd (result f, result f') -instance (DeepArrow ar, DeepArrow ar') => DeepArrow (Pair2 ar ar') where- idA = Pair2 (idA, idA)- dupA = Pair2 (dupA, dupA)- fstA = Pair2 (fstA, fstA)- sndA = Pair2 (sndA, sndA)- funF = Pair2 (funF, funF)- funS = Pair2 (funS, funS)- funR = Pair2 (funR, funR)- curryA = Pair2 (curryA, curryA)- uncurryA = Pair2 (uncurryA, uncurryA)- swapA = Pair2 (swapA, swapA)- lAssocA = Pair2 (lAssocA, lAssocA)- rAssocA = Pair2 (rAssocA, rAssocA)+ -- composeA = Prodd (composeA, composeA)+ -- argument (Prodd (f,f')) = Prodd (argument f, argument f') - result (Pair2 (f,f')) = Pair2 (result f, result f') - -- composeA = Pair2 (composeA, composeA)- -- argument (Pair2 (f,f')) = Pair2 (argument f, argument f')+-- | Support needed for a 'FunA' to be a 'DeepArrow' (as 'FunAble' serves+-- 'Arrow').+class FunAble h => FunDble h where+ resultFun :: (h b -> h b') -> (h (a->b) -> h (a->b'))+ dupAFun :: h a -> h (a,a)+ fstAFun :: h (a,b) -> h a+ sndAFun :: h (a,b) -> h b+ funFFun :: h (c->a, b) -> h (c->(a,b))+ funSFun :: h (a, c->b) -> h (c->(a,b))+ funRFun :: h (a->c->b) -> h (c->a->b)+ curryAFun :: h ((a,b)->c) -> h (a->b->c)+ uncurryAFun :: h (a->b->c) -> h ((a,b)->c)+ swapAFun :: h (a,b) -> h (b,a)+ lAssocAFun :: h (a,(b,c)) -> h ((a,b),c)+ rAssocAFun :: h ((a,b),c) -> h (a,(b,c)) +instance FunDble h => DeepArrow (FunA h) where+ result = inFunA resultFun+ idA = FunA id+ dupA = FunA dupAFun+ fstA = FunA fstAFun+ sndA = FunA sndAFun+ funF = FunA funFFun+ funS = FunA funSFun+ funR = FunA funRFun+ curryA = FunA curryAFun+ uncurryA = FunA uncurryAFun+ swapA = FunA swapAFun+ lAssocA = FunA lAssocAFun+ rAssocA = FunA rAssocAFun++-- (>>>) = inFunA2 (>>>)+-- first = inFunA firstFun+-- second = inFunA secondFun+-- (***) = inFunA2 (***%)+-- (&&&) = inFunA2 (&&&%)+++++ {---------------------------------------------------------- Some utilities ----------------------------------------------------------} -- | Compose wrapped functions-(->|) :: (DeepArrow (~>), FunArr (~>) w) =>- w (a->b) -> w (b->c) -> w (a->c)+(->|) :: (DeepArrow (~>), FunArr (~>) w)+ => w (a->b) -> w (b->c) -> w (a->c) (->|) f g = result (toArr g) $$ f-
src/Control/Arrow/DeepArrow/Examples.hs view
@@ -1,10 +1,12 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE TypeOperators #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts #-} ---------------------------------------------------------------------- -- | -- Module : Control.Arrow.DeepArrow.Examples -- Copyright : (c) Conal Elliott 2007--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental@@ -21,7 +23,7 @@ deep -- * Function extraction , extF, extFF- -- * Input etraction+ -- * Input extraction , extI, extFI ) where
+ src/Data/DDeepArrow.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE GADTs, TypeOperators, KindSignatures, MultiParamTypeClasses #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts -Wall #-}++----------------------------------------------------------------------+-- |+-- Module : Data.DDeepArrow+-- Copyright : (c) Conal Elliott 2006+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : portable+--+-- \"Deep arrows\" as a data type. Handy for code generation.+----------------------------------------------------------------------++module Data.DDeepArrow+ (+ -- * The DeepArrow data type+ DArrow(..), DVal(..)+ ) where++import Control.Arrow++-- haskell-src+import Language.Haskell.Syntax++-- TypeCompose+import Data.Pair (Pair(..))++import Language.Haskell.ToHs+import Control.Arrow.DeepArrow+import Data.FunArr+++{----------------------------------------------------------+ The "deep arrow" data type+----------------------------------------------------------}++-- | This GADT mirrors the 'DeepArrow' class and part of the 'FunArr' class.+data DArrow :: * -> * -> * where+ Arr :: DVal (a -> b) -> a `DArrow` b+ Compose :: a `DArrow` b -> b `DArrow` c -> a `DArrow` c+ First :: a `DArrow` a' -> (a,b) `DArrow` (a',b)+ Second :: b `DArrow` b' -> (a,b) `DArrow` (a,b')+ Result :: b `DArrow` b' -> (a -> b) `DArrow` (a -> b')+ FunF :: (c -> a,b) `DArrow` (c -> (a,b))+ FunS :: (a,c -> b) `DArrow` (c -> (a,b))+ FunR :: (a -> c -> b) `DArrow` (c -> a -> b)+ CurryA :: ((a,b) -> c) `DArrow` (a -> b -> c)+ UncurryA :: (a -> b -> c) `DArrow` ((a,b) -> c)+ LAssocA :: (a,(b,c)) `DArrow` ((a,b),c)+ RAssocA :: ((a,b),c) `DArrow` (a,(b,c))+ IdA :: a `DArrow` a+ DupA :: a `DArrow` (a,a)+ FstA :: (a,b) `DArrow` a+ SndA :: (a,b) `DArrow` b+ SwapA :: (a,b) `DArrow` (b,a)++instance Arrow DArrow where+ arr = error "no arr/pure for DDeepArrow"+ (>>>) = Compose+ first = First+ second = Second++instance DeepArrow DArrow where+ result = Result+ funF = FunF+ funS = FunS+ funR = FunR+ curryA = CurryA+ uncurryA = UncurryA+ lAssocA = LAssocA+ rAssocA = RAssocA+ idA = IdA+ dupA = DupA+ fstA = FstA+ sndA = SndA+ swapA = SwapA++-- | A GADT alternative to terms. Allows generation of Haskell terms and,+-- from there, strings and eval. +data DVal :: * -> * where+ ExpDV :: HsExp -> DVal a+ AppDA :: a `DArrow` b -> DVal a -> DVal b+ PairDV :: DVal a -> DVal b -> DVal (a,b)++instance Pair DVal where pair = PairDV++instance ToHsExp (DArrow a b) where+ toHsExp (Arr dvFun) = toHsExp dvFun+ toHsExp (Compose ab bc) = toHsInfix (HsSymbol ">>>") ab bc+ toHsExp (First f) = toHsApp1 "first" f+ toHsExp (Second f) = toHsApp1 "second" f+ toHsExp (Result f) = toHsApp1 "result" f+ toHsExp FunF = varid "funF"+ toHsExp FunS = varid "funS"+ toHsExp FunR = varid "funR"+ toHsExp CurryA = varid "curryA"+ toHsExp UncurryA = varid "uncurryA"+ toHsExp LAssocA = varid "lAssocA"+ toHsExp RAssocA = varid "rAssocA"+ toHsExp IdA = varid "idA"+ toHsExp DupA = varid "dupA"+ toHsExp FstA = varid "fstA"+ toHsExp SndA = varid "sndA"+ toHsExp SwapA = varid "swapA"++instance ToHsExp (DVal a) where+ toHsExp (ExpDV expr) = expr+ toHsExp (AppDA ar dv) = toHsExp ar `HsApp` toHsExp dv+ -- toHsInfix (HsSymbol "$$") ar dv+ toHsExp (PairDV a b) = HsTuple [toHsExp a, toHsExp b]+++instance FunArr DArrow DVal where+ toArr = Arr+ IdA $$ v = v+ ar $$ v = AppDA ar v+++instance Show (DArrow a b) where show = prettyAsHsExp+instance Show (DVal a) where show = prettyAsHsExp++-- instance H.Eval DVal where eval = compileAsHsExp
src/Data/FunArr.hs view
@@ -1,10 +1,12 @@-{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-}+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FunctionalDependencies #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-} ---------------------------------------------------------------------- -- | -- Module : Data.FunArr -- Copyright : (c) Conal Elliott 2007--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental@@ -15,39 +17,49 @@ module Data.FunArr (- FunArr(..), wapl+ FunArr(..) -- , wapl ) where -import Control.Monad.Identity-import Data.Tupler+-- import Control.Monad.Identity +import Control.Compose+ infixr 0 $$ -- FunArr application -- | Convert between an arrow value and a \"wrapped function\". The \"arrow\" -- doesn't really have to be an arrow. I'd appreciate ideas for names & -- uses.-class FunArr (~>) w | (~>)->w, w->(~>) where+class FunArr (~>) w | (~>)->w , w->(~>) where -- | Convert a @w@-wrapped function to an arrow value toArr :: w (a->b) -> (a ~> b) -- | Apply an arrow to a @w@-wrapped value ($$) :: (a ~> b) -> w a -> w b --- | Apply a wrapped function to a wrapped value-wapl :: FunArr (~>) w => w (a->b) -> w a -> w b-wapl f a = toArr f $$ a+-- -- | Apply a wrapped function to a wrapped value+-- wapl :: FunArr (~>) w => w (a->b) -> w a -> w b+-- wapl f a = toArr f $$ a +-- The type of wapl matches <*> from Control.Applicative. What about+-- "pure" from the Applicative class, with type a -> w a?+ -- Function/Id instance-instance FunArr (->) Identity where- toArr = runIdentity- f $$ ida = return (f (runIdentity ida))- -- ($$) f = return . f . runIdentity+instance FunArr (->) Id where+ toArr (Id f) = f+ f $$ Id a = Id (f a) +-- -- Oops! This instance can't work with the mutual functional+-- dependencies. Instead, instantiate it per @h@.+-- instance FunArr (FunA h) h where+-- toArr = error "toArr: undefined for FunArr" -- Add FunArrable class & delegate+-- FunA f $$ ha = f ha++ -- The following instance violates the "coverage condition" and so -- requires -fallow-undecidable-instances. instance (FunArr ar w, FunArr ar' w')- => FunArr (Pair2 ar ar') (Pair1 w w') where- toArr (Pair1 (f,f')) = Pair2 (toArr f, toArr f')- Pair2 (f,f') $$ Pair1 (w,w') = Pair1 (f $$ w, f' $$ w')+ => FunArr (ar ::*:: ar') (w :*: w') where+ toArr (Prod (f,f')) = Prodd (toArr f, toArr f')+ Prodd (f,f') $$ Prod (w,w') = Prod (f $$ w, f' $$ w')
− src/Data/Tupler.hs
@@ -1,66 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--------------------------------------------------------------------------- |--- Module : Data.Tupler--- Copyright : (c) Conal Elliott 2007--- License : LGPL--- --- Maintainer : conal@conal.net--- Stability : experimental--- Portability : portable--- --- The tuple type constructors (i.e., (,), (,,), etc) are to value types,--- as the /tupler/ type constructors are to type constructors.-------------------------------------------------------------------------module Data.Tupler- (- Pair1(..), Pair2(..)- ) where---import Data.Typeable -- or AltData.Typeable ?---- | Pairing for unary type constructors.-newtype Pair1 f g a = Pair1 {unPair1 :: (f a, g a)}- deriving (Eq, Ord, Show)--instance (Typeable1 f, Typeable1 g) => Typeable1 (Pair1 f g) where- typeOf1 = const $ mkTyConApp (mkTyCon tyConStr) []- where- tyConStr = "Data.Tupler.Pair1"- ++ tcStringSP (undefined :: f Bool)- ++ tcStringSP (undefined :: g Bool)---- | Pairing for binary type constructors.-newtype Pair2 f g a b = Pair2 {unPair2 :: (f a b, g a b)}- deriving (Eq, Ord, Show)--instance (Typeable2 f, Typeable2 g) => Typeable2 (Pair2 f g) where- typeOf2 = const $ mkTyConApp (mkTyCon tyConStr) []- where- tyConStr = "Data.Tupler.Pair2"- ++ tcStringSP (undefined :: f Bool Bool)- ++ tcStringSP (undefined :: g Bool Bool)------- Misc---- | Disambuating hack for a function argument. Wrap parens around a string--- if it contains a space.-parensIfSpace :: String -> String-parensIfSpace str | ' ' `elem` str = "("++str++")"- | otherwise = str---- | Extract the type constructor as a string-tcString :: Typeable a => a -> String-tcString = tyConString . typeRepTyCon . typeOf---- | 'tcString' with disambiguating optional parens-tcStringP :: Typeable a => a -> String-tcStringP = parensIfSpace . tcString---- | 'tcString' with leading space and optional parens-tcStringSP :: Typeable a => a -> String-tcStringSP = (' ':) . tcStringP
+ src/Language/Haskell/Parens.hs view
@@ -0,0 +1,230 @@+----------------------------------------------------------------------+-- |+-- Module : Language.Haskell.Parens+-- Copyright : (c) Conal Elliott 2007+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : ???+-- +-- Insert parens where necessary in Haskell expressions.+-- Inspired by Sigbjorn Finne's Pan pretty-printer.+----------------------------------------------------------------------++module Language.Haskell.Parens+ (+ pretty, Cify, cifyExp, unCify, hasOpInfo+ )+ where++-- haskell-src+import Language.Haskell.Syntax+import Language.Haskell.Pretty (prettyPrint)++pretty :: HsExp -> String+pretty = prettyPrint . unCify . cifyExp++-- Associativity+data Assoc = LAssoc | NAssoc | RAssoc deriving ( Eq )++-- Associativity and precedence+type OpInfo = (Assoc, Int)++-- Context in which an expression appears. Oper info and whether we're on+-- the right.+type Context = (OpInfo, Bool)++type CExp = Context -> HsExp+++-- Given an "inner" operator application "a `opi` b", in the context of an+-- application of an outer operator "opo", insert parens around the inner+-- iff+-- +-- + opo has a higher precedence than opi, or+-- + opo has the same precedence as opi, and either+-- - opo & opi differs in associativity direction, or+-- - opo & opi have the same associativity direction, and either+-- * "a `opi` b" occurs on the right, and opo is not right-assoc, or+-- * "a `opi` b" occurs on the left, and opo is not left-assoc.++oper :: OpInfo -> CExp -> CExp+oper i@(asi,pri) cexp ((aso,pro),onR) = mbParens (cexp c')+ where -- i=inner, o=outer+ mbParens | needParens = HsParen+ | otherwise = id+ c' = (i,False)+ needParens = pro > pri || (pro == pri && conflict)+ conflict = aso /= asi || onR /= (aso == RAssoc)++-- Reset context.+reset :: CExp -> CExp+reset = oper (NAssoc,0)++-- Whether the inner application is on the right.+onRight :: Bool -> CExp -> CExp+onRight onR cexp (opi,_) = cexp (opi,onR)++-- Generally handy lifters+lift1 :: (a->b) -> (z->a) -> (z->b)+lift1 = (.)++lift2 :: (a->b->c) -> (z->a) -> (z->b) -> (z->c)+lift2 f h1 h2 c = f (h1 c) (h2 c)++lift3 :: (a->b->c->d) -> (z->a) -> (z->b) -> (z->c) -> (z->d)+lift3 f h1 h2 h3 c = f (h1 c) (h2 c) (h3 c)++-- Make context-dependent version that inserts parens+type Cify a = a -> (Context -> a)++-- Provide initial context.+unCify :: (Context -> a) -> a+unCify = ($ ((NAssoc,0),False))++cifyExp :: Cify HsExp+cifyExp e =+ case e of+ HsVar _ -> const e+ HsCon _ -> const e+ HsLit _ -> const e+ HsLambda loc pats body -> reset $+ lift1 (HsLambda loc pats) (cifyExp body)+ HsInfixApp el op er -> oper (opInfo (opName op)) $+ lift2 (flip HsInfixApp op)+ (onRight False (cifyExp el))+ (onRight True (cifyExp er))+ HsApp fun arg -> oper (opInfo (HsSymbol "")) $+ lift2 HsApp + (onRight False (cifyExp fun))+ (onRight True (cifyExp arg))+ HsNegApp arg -> oper (opInfo (HsSymbol "-")) $+ lift1 HsNegApp (onRight True (cifyExp arg))+ HsLet decls body -> reset $+ lift2 HsLet+ (cifyDecls decls)+ (cifyExp body)+ HsIf c a b -> reset $+ lift3 HsIf (cifyExp c) (cifyExp a) (cifyExp b)++ HsTuple exps -> reset $+ lift1 HsTuple (cifyExps exps)+ HsParen e' -> cifyExp e'++ -- TODO: fill in other cases++ _ -> error $ "cifyExp: unhandled case " ++ show e++-- Some other syntactic categories. Many missing productions.++cifyExps :: Cify [HsExp]+cifyExps exps c = map (flip cifyExp c) exps++cifyDecls :: Cify [HsDecl]+cifyDecls decls c = map (flip cifyDecl c) decls++cifyDecl :: Cify HsDecl+cifyDecl (HsPatBind loc pat rhs []) =+ lift1 (\ r -> HsPatBind loc pat r [])+ (cifyRhs rhs)+cifyDecl decl = error $ "cifyDecl: unhandled case " ++ show decl++-- TODO: fill in other cases++cifyRhs :: Cify HsRhs+cifyRhs (HsUnGuardedRhs expr) = lift1 HsUnGuardedRhs (cifyExp expr)+cifyRhs rhs = error $ "cifyRhs: unhandled case " ++ show rhs++-- TODO: fill in other cases++---- Operator info++opQName :: HsQOp -> HsQName+opQName (HsQVarOp qname) = qname+opQName (HsQConOp qname) = qname++opName :: HsQOp -> HsName+opName = getName . opQName++-- Next two swiped from Haskell.Language.Pretty (not exported)+getName :: HsQName -> HsName+getName (UnQual s) = s+getName (Qual _ s) = s+getName (Special HsCons) = HsSymbol ":"+getName (Special HsFunCon) = HsSymbol "->"+getName (Special s) = HsIdent (specialName s)++specialName :: HsSpecialCon -> String+specialName HsUnitCon = "()"+specialName HsListCon = "[]"+specialName HsFunCon = "->"+specialName (HsTupleCon n) = "(" ++ replicate (n-1) ',' ++ ")"+specialName HsCons = ":"+++apPrec :: Int+apPrec = 10++-- Precedences & fixities. Derived from the prelude. Add more as+-- desired. Really the operators should be extensible.+opInfo :: HsName -> OpInfo+opInfo name = case name of+ -- From the Prelude+ HsSymbol "" -> (LAssoc, apPrec) -- jux/application+ HsSymbol "." -> (RAssoc, 9)+ HsSymbol "!!" -> (LAssoc, 9)+ HsSymbol "^" -> (RAssoc, 8)+ HsSymbol "^^" -> (RAssoc, 8)+ HsSymbol "**" -> (RAssoc, 8)+ HsSymbol "*" -> (LAssoc, 7)+ HsSymbol "/" -> (LAssoc, 7)+ HsIdent "quot" -> (LAssoc, 7)+ HsIdent "rem" -> (LAssoc, 7)+ HsIdent "div" -> (LAssoc, 7)+ HsIdent "mod" -> (LAssoc, 7)+ HsSymbol ":%" -> (LAssoc, 7)+ HsSymbol "%" -> (LAssoc, 7)+ HsSymbol "+" -> (LAssoc, 6)+ HsSymbol "-" -> (LAssoc, 6)+ HsSymbol ":" -> (RAssoc, 5)+ HsSymbol "++" -> (RAssoc, 5)+ HsSymbol "==" -> (NAssoc, 4)+ HsSymbol "/=" -> (NAssoc, 4)+ HsSymbol "<" -> (NAssoc, 4)+ HsSymbol "<=" -> (NAssoc, 4)+ HsSymbol ">=" -> (NAssoc, 4)+ HsSymbol ">" -> (NAssoc, 4)+ HsIdent "elem" -> (NAssoc, 4)+ HsIdent "notElem" -> (NAssoc, 4)+ HsSymbol "&&" -> (RAssoc, 3)+ HsSymbol "||" -> (RAssoc, 2)+ HsSymbol ">>" -> (LAssoc, 1)+ HsSymbol ">>=" -> (LAssoc, 1)+ HsSymbol "=<<" -> (RAssoc, 1)+ HsSymbol "$" -> (RAssoc, 0)+ HsSymbol "$!" -> (RAssoc, 0)+ HsIdent "seq" -> (RAssoc, 0)++ -- From Control.Arrow+ HsSymbol "<+>" -> (RAssoc, 5)+ HsSymbol "***" -> (RAssoc, 3)+ HsSymbol "&&&" -> (RAssoc, 3)+ HsSymbol "+++" -> (RAssoc, 2)+ HsSymbol "|||" -> (RAssoc, 2)+ HsSymbol ">>>" -> (RAssoc, 1)+ HsSymbol "^>>" -> (RAssoc, 1)+ HsSymbol ">>^" -> (RAssoc, 1)+ HsSymbol "<<<" -> (RAssoc, 1)+ HsSymbol "^<<" -> (RAssoc, 1)+ HsSymbol "<<^" -> (RAssoc, 1)++ -- Mine+ HsSymbol "*^" -> (LAssoc, 7)+ HsSymbol "^+^" -> (LAssoc, 6)++ -- Bail out+ _ -> (NAssoc, -1) -- no op info++hasOpInfo :: HsName -> Bool+hasOpInfo name = snd (opInfo name) >= 0
+ src/Language/Haskell/ToHs.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TypeSynonymInstances #-}+----------------------------------------------------------------------+-- |+-- Module : Language.Haskell.ToHs+-- Copyright : (c) Conal Elliott 2007+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Convert values to Haskell abstract syntax+----------------------------------------------------------------------++module Language.Haskell.ToHs+ (+ ToHsExp(..), varid, varsym+ , toHsApp1, toHsApp2, infixApp, toHsInfix+ , prettyAsHsExp+ ) where++-- haskell-src+import Language.Haskell.Syntax++-- DeepArrow+import Language.Haskell.Parens (pretty)++-- -- | Phantomly Typed Haskell expression+-- data HsExpr a = HsExp++-- | Conversion to Haskell expressions+class ToHsExp a where toHsExp :: a -> HsExp++instance ToHsExp Char where toHsExp = HsLit . HsCharPrim+instance ToHsExp String where toHsExp = HsLit . HsStringPrim+instance ToHsExp Int where toHsExp = HsLit . HsIntPrim . toInteger+instance ToHsExp Float where toHsExp = HsLit . HsFloatPrim . toRational+instance ToHsExp Double where toHsExp = HsLit . HsFloatPrim . toRational+instance ToHsExp Bool where toHsExp = varid . show++varid :: String -> HsExp+varid = HsVar . UnQual . HsIdent++varsym :: String -> HsExp+varsym = HsVar . UnQual . HsSymbol++toHsApp1 :: ToHsExp a => String -> a -> HsExp+toHsApp1 name a = varid name `HsApp` toHsExp a++toHsApp2 :: (ToHsExp a, ToHsExp b) => String -> a -> b -> HsExp+toHsApp2 name a b = toHsApp1 name a `HsApp` toHsExp b++infixApp :: HsName -> HsExp -> HsExp -> HsExp+infixApp op l r = HsParen (HsInfixApp l (HsQVarOp (UnQual op)) r)++toHsInfix :: (ToHsExp a, ToHsExp b) => HsName -> a -> b -> HsExp+toHsInfix name a b = infixApp name (toHsExp a) (toHsExp b)++prettyAsHsExp :: ToHsExp a => a -> String+prettyAsHsExp = pretty . toHsExp+++-- compileAsHsExp :: ToHsExp (k a) => Ty a -> k a -> a+-- compileAsHsExp tya e =+-- compileD tya (error "compile: no default") (pretty (toHsExp e))