CCA 0.1.3 → 0.1.4
raw patch · 8 files changed
+115/−132 lines, 8 files
Files
- CCA.cabal +9/−10
- Changelog +36/−0
- dist/build/ccap/ccap-tmp/Parser.hs +33/−47
- preprocessor/Main.lhs +10/−7
- src/Control/CCA/CCNF.lhs +5/−1
- src/Language/Haskell/TH/Instances.hs +21/−0
- test/Makefile +1/−1
- test/Sample1.hs +0/−66
CCA.cabal view
@@ -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 <paul@thev.net>, Eric Cheng <eric.cheng@yale.edu>+Author: Paul H Liu <paul@thev.net>, Eric Cheng <eric.cheng@aya.yale.edu> Maintainer: Paul H Liu <paul@thev.net> 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/
+ Changelog view
@@ -0,0 +1,36 @@+Thu May 30 00:38:10 PDT 2013 Paul Liu <paul@thev.net>+ * Bump version to 0.1.4++Tue May 14 20:09:56 PDT 2013 Paul Liu <paul@thev.net>+ * 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
dist/build/ccap/ccap-tmp/Parser.hs view
@@ -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" -----------------------------------------------------------------------------
preprocessor/Main.lhs view
@@ -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 ->
src/Control/CCA/CCNF.lhs view
@@ -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|]
src/Language/Haskell/TH/Instances.hs view
@@ -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|]
test/Makefile view
@@ -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
− test/Sample1.hs
@@ -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)-