diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -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 diff --git a/DeepArrow.cabal b/DeepArrow.cabal --- a/DeepArrow.cabal +++ b/DeepArrow.cabal @@ -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 diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 diff --git a/src/Control/Arrow/DeepArrow.hs b/src/Control/Arrow/DeepArrow.hs --- a/src/Control/Arrow/DeepArrow.hs +++ b/src/Control/Arrow/DeepArrow.hs @@ -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 - diff --git a/src/Control/Arrow/DeepArrow/Examples.hs b/src/Control/Arrow/DeepArrow/Examples.hs --- a/src/Control/Arrow/DeepArrow/Examples.hs +++ b/src/Control/Arrow/DeepArrow/Examples.hs @@ -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 diff --git a/src/Data/DDeepArrow.hs b/src/Data/DDeepArrow.hs new file mode 100644 --- /dev/null +++ b/src/Data/DDeepArrow.hs @@ -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 diff --git a/src/Data/FunArr.hs b/src/Data/FunArr.hs --- a/src/Data/FunArr.hs +++ b/src/Data/FunArr.hs @@ -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') diff --git a/src/Data/Tupler.hs b/src/Data/Tupler.hs deleted file mode 100644 --- a/src/Data/Tupler.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Parens.hs b/src/Language/Haskell/Parens.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Parens.hs @@ -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 diff --git a/src/Language/Haskell/ToHs.hs b/src/Language/Haskell/ToHs.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/ToHs.hs @@ -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))