diff --git a/CCA.cabal b/CCA.cabal --- a/CCA.cabal +++ b/CCA.cabal @@ -1,10 +1,10 @@ Name: CCA -Version: 0.1.3 +Version: 0.1.4 Cabal-Version: >= 1.6 Build-Type: Simple License: BSD3 License-File: LICENSE -Author: Paul H Liu , Eric Cheng +Author: Paul H Liu , Eric Cheng Maintainer: Paul H Liu Homepage: not available Category: Development @@ -16,11 +16,10 @@ and outputs Haskell 98 + Template Haskell sources for use with CCA library. Extra-Source-Files: - README, LICENSE.arrowp, README.arrowp, + Changelog, README, LICENSE.arrowp, README.arrowp, test/Makefile test/Main.hs test/Sample.as - test/Sample1.hs library @@ -32,11 +31,11 @@ build-depends: base >= 4 && < 5, syb, ghc-prim Executable ccap - Main-is: Main.lhs - Other-Modules: ArrCode ArrSyn Lexer Parser Parser State Utils - Build-Depends: base >= 3 && < 5, array, containers, haskell-src - Hs-Source-Dirs: preprocessor + Main-is: Main.lhs + Other-Modules: ArrCode ArrSyn Lexer Parser Parser State Utils + Build-Depends: base >= 3 && < 5, array, containers, haskell-src + Hs-Source-Dirs: preprocessor source-repository head - type: darcs - location: http://code.haskell.org/CCA/ + type: darcs + location: http://code.haskell.org/CCA/ diff --git a/Changelog b/Changelog new file mode 100644 --- /dev/null +++ b/Changelog @@ -0,0 +1,36 @@ +Thu May 30 00:38:10 PDT 2013 Paul Liu + * Bump version to 0.1.4 + +Tue May 14 20:09:56 PDT 2013 Paul Liu + * Remove obsolete GHC options from Makefile + +Tue May 14 07:22:04 PDT 2013 svenkeidel@gmail.com + * fixes for compilation with ghc 7.6.3 + + Problem 1 Template Haskell: + In template-haskell <= 2.7.0.0, "Kind" is a own data type (see [1]). + In template-haskell == 2.8.0.0, they made "Kind" a type alias of "Type" to + avoid duplication (see [2]). + + Problem 2 Catch: + Prelude in base == 4.6.0.0 discards the "catch" function. See [3] and [4] + + [1] http://hackage.haskell.org/packages/archive/template-haskell/2.7.0.0/doc/html/Language-Haskell-TH-Syntax.html#t:Kind + [2] http://hackage.haskell.org/packages/archive/template-haskell/2.8.0.0/doc/html/Language-Haskell-TH-Syntax.html#t:Kind + [3] http://hackage.haskell.org/packages/archive/base/4.5.0.0/doc/html/Prelude.html#v:catch + [4] http://hackage.haskell.org/packages/archive/base/4.6.0.0/doc/html/Prelude.html + +Sun Jan 16 04:04:50 PST 2011 jwlato@gmail.com + * add some type signatures to CCNF.lhs + +Sun Dec 5 11:59:35 PST 2010 jwlato@gmail.com + * add "normOpt" result for "Arr" constructor (pure function arrows) + +Mon Apr 12 21:01:06 PDT 2010 paul@thev.net + * Normalize to loopD instead of loopB + add more test cases + add support for GHC 6.12.1 + bump version to 0.1.3. + +Thu Sep 10 04:48:37 PDT 2009 paul@thev.net + * initial code import from CCA-0.1.1 diff --git a/dist/build/ccap/ccap-tmp/Parser.hs b/dist/build/ccap/ccap-tmp/Parser.hs --- a/dist/build/ccap/ccap-tmp/Parser.hs +++ b/dist/build/ccap/ccap-tmp/Parser.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} +{-# OPTIONS_GHC -w #-} {-# OPTIONS -fglasgow-exts -cpp #-} ----------------------------------------------------------------------------- -- | @@ -24,18 +24,10 @@ import Language.Haskell.ParseUtils import qualified ArrSyn -- added for arrows -#if __GLASGOW_HASKELL__ >= 503 import qualified Data.Array as Happy_Data_Array -#else -import qualified Array as Happy_Data_Array -#endif -#if __GLASGOW_HASKELL__ >= 503 import qualified GHC.Exts as Happy_GHC_Exts -#else -import qualified GlaExts as Happy_GHC_Exts -#endif --- parser produced by Happy Version 1.18.4 +-- parser produced by Happy Version 1.18.9 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 @@ -4540,7 +4532,8 @@ _ -> happyError' tk }) -happyError_ tk = happyError' tk +happyError_ 77# tk = happyError' tk +happyError_ _ tk = happyError' tk happyThen :: () => P a -> (a -> P b) -> P b happyThen = (>>=) @@ -4575,7 +4568,7 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp -{-# LINE 28 "templates/GenericTemplate.hs" #-} +{-# LINE 30 "templates/GenericTemplate.hs" #-} data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList @@ -4584,11 +4577,11 @@ -{-# LINE 49 "templates/GenericTemplate.hs" #-} +{-# LINE 51 "templates/GenericTemplate.hs" #-} -{-# LINE 59 "templates/GenericTemplate.hs" #-} +{-# LINE 61 "templates/GenericTemplate.hs" #-} -{-# LINE 68 "templates/GenericTemplate.hs" #-} +{-# LINE 70 "templates/GenericTemplate.hs" #-} infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a) @@ -4631,35 +4624,26 @@ happyShift new_state i tk st - where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off Happy_GHC_Exts.+# i) + where (new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where (off) = indexShortOffAddr happyActOffsets st + (off_i) = (off Happy_GHC_Exts.+# i) check = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#)) then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i) else False - action | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st + (action) + | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st -{-# LINE 127 "templates/GenericTemplate.hs" #-} +{-# LINE 130 "templates/GenericTemplate.hs" #-} indexShortOffAddr (HappyA# arr) off = -#if __GLASGOW_HASKELL__ > 500 Happy_GHC_Exts.narrow16Int# i -#elif __GLASGOW_HASKELL__ == 500 - Happy_GHC_Exts.intToInt16# i -#else - Happy_GHC_Exts.iShiftRA# (Happy_GHC_Exts.iShiftL# i 16#) 16# -#endif where -#if __GLASGOW_HASKELL__ >= 503 - i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) -#else - i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.shiftL# high 8#) low) -#endif - high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - off' = off Happy_GHC_Exts.*# 2# + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) + high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + off' = off Happy_GHC_Exts.*# 2# @@ -4673,13 +4657,13 @@ ----------------------------------------------------------------------------- -- HappyState data type (not arrays) -{-# LINE 170 "templates/GenericTemplate.hs" #-} +{-# LINE 163 "templates/GenericTemplate.hs" #-} ----------------------------------------------------------------------------- -- Shifting a token happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in + let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in -- trace "shifting the error token" $ happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) @@ -4723,19 +4707,19 @@ = happyFail 0# tk st sts stk happyMonadReduce k nt fn j tk st sts stk = happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) drop_stk = happyDropStk k stk happyMonad2Reduce k nt fn 0# tk st sts stk = happyFail 0# tk st sts stk happyMonad2Reduce k nt fn j tk st sts stk = happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) drop_stk = happyDropStk k stk - off = indexShortOffAddr happyGotoOffsets st1 - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i + (off) = indexShortOffAddr happyGotoOffsets st1 + (off_i) = (off Happy_GHC_Exts.+# nt) + (new_state) = indexShortOffAddr happyTable off_i @@ -4753,9 +4737,9 @@ happyGoto nt j tk st = {- nothing -} happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i + where (off) = indexShortOffAddr happyGotoOffsets st + (off_i) = (off Happy_GHC_Exts.+# nt) + (new_state) = indexShortOffAddr happyTable off_i @@ -4764,9 +4748,10 @@ -- Error recovery (0# is the error token) -- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk = +happyFail 0# tk old_st _ stk@(x `HappyStk` _) = + let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in -- trace "failing" $ - happyError_ tk + happyError_ i tk {- We don't need state discarding for our restricted implementation of "error". In fact, it can cause some bogus parses, so I've disabled it @@ -4787,6 +4772,7 @@ -- Internal happy errors: +notHappyAtAll :: a notHappyAtAll = error "Internal Happy error\n" ----------------------------------------------------------------------------- diff --git a/preprocessor/Main.lhs b/preprocessor/Main.lhs --- a/preprocessor/Main.lhs +++ b/preprocessor/Main.lhs @@ -6,6 +6,9 @@ > import System.Exit > import System.IO +> import Control.Exception +> import Prelude hiding (catch) + > import Language.Haskell.ParseMonad > import Language.Haskell.Syntax > import Language.Haskell.Pretty @@ -33,8 +36,8 @@ > " in column " ++ show (srcColumn loc)) > exitFailure -> programError :: String -> IO a -> programError mesg = do +> programError :: SomeException -> String -> IO a +> programError e mesg = do > progName <- getProgName > hPutStrLn stderr (progName ++ ": " ++ mesg) > exitFailure @@ -42,7 +45,7 @@ > usageError :: String -> IO a > usageError mesg = do > progName <- getProgName -> programError (mesg ++ +> programError undefined (mesg ++ > "Try `" ++ progName ++ " --help' for more information.") > options :: [OptDescr Flag] @@ -94,11 +97,11 @@ > _ -> usageError "too many arguments\n" > let mode = defaultParseMode {parseFilename = origName} > inp <- if inName == "-" then getContents else -> readFile inName `catch` \_err -> -> programError ("can't read `" ++ inName ++ "'") +> readFile inName `catch` \err -> +> programError err ("can't read `" ++ inName ++ "'") > outH <- if outName == "-" then return stdout else -> openFile outName WriteMode `catch` \_err -> -> programError ("can't write to `" ++ outName ++ "'") +> openFile outName WriteMode `catch` \err -> +> programError err ("can't write to `" ++ outName ++ "'") > outp <- case action of > ParsePretty layout -> case parseModuleWithMode mode inp of > ParseOk mod -> diff --git a/src/Control/CCA/CCNF.lhs b/src/Control/CCA/CCNF.lhs --- a/src/Control/CCA/CCNF.lhs +++ b/src/Control/CCA/CCNF.lhs @@ -124,7 +124,8 @@ > normOpt (AExp e) = > case normE e of > LoopD i f -> tupE [i, f] -> _ -> error "The given arrow can't be normalized to optimized CCNF." +> Arr f -> [| ( (), $(f) ) |] +> _ -> error "The given arrow can't be normalized to optimized CCNF." pprNorm and pprNormOpt return the pretty printed normal forms as a string. @@ -135,6 +136,7 @@ fromAExp converts AExp back to TH Exp structure. +> fromAExp :: AExp -> ExpQ > fromAExp (Arr f) = appE [|arr|] f > fromAExp (First f) = appE [|first|] (fromAExp f) > fromAExp (f :>>> g) = infixE (Just (fromAExp f)) [|(>>>)|] (Just (fromAExp g)) @@ -205,8 +207,10 @@ > Left (x, y) -> (Left x, y) > Right (x, y) -> (Right x, y) +> o :: ExpQ -> ExpQ -> ExpQ > f `o` g = appE (appE [|(.)|] f) g > f `crossE` g = appE (appE [|cross|] f) g +> idE :: ExpQ > idE = [|id|] > dupE = [|dup|] > swapE = [|swap|] diff --git a/src/Language/Haskell/TH/Instances.hs b/src/Language/Haskell/TH/Instances.hs --- a/src/Language/Haskell/TH/Instances.hs +++ b/src/Language/Haskell/TH/Instances.hs @@ -48,10 +48,26 @@ lift (ClassP n ts) = [|ClassP n ts|] lift (EqualP t t2) = [|EqualP t t2|] +#if MIN_VERSION_template_haskell(2,8,0) + instance Lift Kind where + lift StarT = [|StarT|] + lift (ForallT n c t) = [|ForallT n c t|] + lift (VarT n) = [|VarT n|] + lift (ConT n) = [|ConT n|] + lift (TupleT i) = [|TupleT i|] + lift (ArrowT) = [|ArrowT|] + lift (ListT) = [|ListT|] + lift (AppT t1 t2) = [|AppT t1 t2|] + +#else + +instance Lift Kind where lift StarK = [|StarK|] lift (ArrowK k1 k2) = [|ArrowK k1 k2|] +#endif + instance Lift TyVarBndr where lift (PlainTV n) = [|PlainTV n|] lift (KindedTV n k) = [|KindedTV n k|] @@ -80,6 +96,9 @@ instance Lift Match where lift (Match p b d) = [|Match p b d|] + +#if ! MIN_VERSION_template_haskell(2,8,0) + instance Lift Type where lift (ForallT n c t) = [|ForallT n c t|] lift (VarT n) = [|VarT n|] @@ -88,6 +107,8 @@ lift (ArrowT) = [|ArrowT|] lift (ListT) = [|ListT|] lift (AppT t1 t2) = [|AppT t1 t2|] + +#endif instance Lift Pat where lift (LitP l) = [|LitP l|] diff --git a/test/Makefile b/test/Makefile --- a/test/Makefile +++ b/test/Makefile @@ -1,6 +1,6 @@ GHC = ghc ARROWP = ccap -FLAGS = -fvia-C -fno-method-sharing -fexcess-precision -O2 -XTemplateHaskell +FLAGS = -fexcess-precision -O2 -XTemplateHaskell Main: Main.hs Sample.hs Sample1.hs $(GHC) $(FLAGS) --make Main.hs diff --git a/test/Sample1.hs b/test/Sample1.hs deleted file mode 100644 --- a/test/Sample1.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE Arrows #-} -module Sample1 where - - -import Control.Arrow -import Control.CCA.Types -import Prelude hiding (init, exp) - -sr = 44100 :: Int -dt = 1 / (fromIntegral sr) - -exp :: ArrowInit a => a () Double -exp = proc () -> do - rec let e = 1 + i - i <- integral -< e - returnA -< e - -integral :: ArrowInit a => a Double Double -integral = proc x -> do - rec let i' = i + x * dt - i <- init 0 -< i' - returnA -< i - -sine :: ArrowInit a => Double -> a () Double -sine freq = proc _ -> do - rec x <- init i -< r - y <- init 0 -< x - let r = c * x - y - returnA -< r - where - omh = 2 * pi / (fromIntegral sr) * freq - i = sin omh - c = 2 * cos omh - -oscSine :: ArrowInit a => Double -> a Double Double -oscSine f0 = proc cv -> do - let f = f0 * (2 ** cv) - phi <- integral -< 2 * pi * f - returnA -< sin phi - -testOsc :: ArrowInit a => (Double -> a Double Double) -> a () Double -testOsc f = arr (const 1) >>> f 440 - -sciFi :: ArrowInit a => a () Double -sciFi = proc () -> do - und <- oscSine 3.0 -< 0 - swp <- integral -< -0.25 - audio <- oscSine 440 -< und * 0.2 + swp + 1 - returnA -< audio - -robot :: ArrowInit a => a (Double, Double) Double -robot = proc inp -> do - let vr = snd inp - vl = fst inp - vz = vr + vl - t <- integral -< vr - vl - let t' = t / 10 - x <- integral -< vz * cos t' - y <- integral -< vz * sin t' - returnA -< x / 2 + y / 2 - -testRobot :: ArrowInit a => a (Double, Double) Double -> a () Double -testRobot bot = proc () -> do - u <- sine 2 -< () - robot -< (u, 1 - u) -