packages feed

arrowp-qq 0.2.1 → 0.2.1.1

raw patch · 7 files changed

+40/−55 lines, 7 filesdep ~haskell-src-exts-utilPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: haskell-src-exts-util

API changes (from Hackage documentation)

Files

arrowp-qq.cabal view
@@ -1,5 +1,5 @@ Name:           arrowp-qq-Version:        0.2.1+Version:        0.2.1.1 Cabal-Version:  >= 1.20 Build-Type:     Simple License:        GPL@@ -34,7 +34,7 @@                    containers,                    data-default,                    haskell-src-exts,-                   haskell-src-exts-util,+                   haskell-src-exts-util >= 0.2.0,                    haskell-src-meta,                    template-haskell < 2.13,                     transformers,
examples/Static.hs view
@@ -3,7 +3,7 @@  import Control.Arrow -ifEx :: Arrow a => Bool -> a inp out -> a out () -> a inp out+ifEx :: Arrow a => Bool -> a v v -> a v () -> a v v ifEx outputResultsArg processor outputSink = proc inputs -> do   results <- processor -< inputs   if outputResultsArg@@ -11,7 +11,7 @@     else returnA -< ()   processor -< results -ifEx' :: Arrow a => Bool -> a inp out -> a out () -> a inp out+ifEx' :: Arrow a => Bool -> a v v -> a v v -> a v v ifEx' outputResultsArg processor outputSink = proc inputs -> do   results <- processor -< inputs   results <- if outputResultsArg@@ -19,7 +19,7 @@     else returnA -< results   processor -< results -caseEx :: Arrow a => Bool -> a inp out -> a out () -> a inp out+caseEx :: Arrow a => Bool -> a v v -> a v () -> a v v caseEx outputResultsArg processor outputSink = proc inputs -> do   results <- processor -< inputs   case outputResultsArg of@@ -27,7 +27,7 @@     False -> returnA -< ()   processor -< results -caseEx' :: Arrow a => Bool -> a inp out -> a out () -> a inp out+caseEx' :: Arrow a => Bool -> a v v -> a v v -> a v v caseEx' outputResultsArg processor outputSink = proc inputs -> do   results <- processor -< inputs   results <- case outputResultsArg of
src/ArrCode.hs view
@@ -21,8 +21,6 @@   , infixOp   , (|||)   , first-  , context-  , anonArgs   , toHaskell   , Tuple(..)   , isEmptyTuple@@ -49,11 +47,6 @@   }   deriving (Eq, Generic, Show) -instance Located Arrow  where-  type LocType Arrow = Code-  location f (Arrow context anon code)=-    Arrow context anon <$> location f code- instance Observable Arrow  loop :: Arrow -> Arrow@@ -62,7 +55,7 @@ app :: Arrow app = arrowExp app_exp -bind :: Set (Name S) -> Arrow -> Arrow+bind :: Set (Name ()) -> Arrow -> Arrow bind = observe "bind" $ \vars a -> a {context = context a `minusTuple` vars} anon :: Int -> Arrow -> Arrow anon anonCount a = a {anonArgs = anonArgs a + anonCount}@@ -142,7 +135,7 @@ compose' :: Exp Code -> Exp Code -> Exp Code compose' ReturnA{} a = a compose' a ReturnA{} = a-compose' a1@(Arr l1 n1 p1 ds1 e1) a2@(Arr l2 n2 p2 ds2 e2)+compose' a1@(Arr l1 n1 p1 ds1 e1) a2@(Arr _l2 n2 p2 ds2 e2)   | n1 /= n2 = Compose a1 [] a2 -- could do better, but can this arise?   | same p2 e1 = Arr l1 n1 p1 (ds1 ++ ds2) e2   | otherwise = Arr l1 n1 p1 (ds1 ++ BindCase p2 e1 : ds2) e2@@ -180,44 +173,46 @@       If l (getLoc <$> cond) (toHaskellCode th) (toHaskellCode el)     toHaskellCode (Case (Loc l) e alts) =       Case l (getLoc <$> e) (toHaskellAlt <$> alts)+    toHaskellCode other = error $ "toHaskellCode: " ++ show other     toHaskellAlt (Alt (Loc l) pat rhs binds) =       Alt l (getLoc <$> pat) (toHaskellRhs rhs) (getLoc <$$> binds)+    toHaskellAlt other = error $ "toHaskellAlt: " ++ show other     toHaskellRhs (UnGuardedRhs (Loc l) e) = UnGuardedRhs l (toHaskellCode e)     toHaskellRhs (GuardedRhss (Loc l) rhss) =       GuardedRhss l (toHaskellGuardedRhs <$> rhss)+    toHaskellRhs other = error $ "toHaskellRhs: " ++ show other     toHaskellGuardedRhs (GuardedRhs (Loc l) stmts e) =       GuardedRhs l (getLoc <$$> stmts) (toHaskellCode e)+    toHaskellGuardedRhs other = error $ "toHaskellGuardedRhs: " ++ show other     toHaskellArg = Paren def . toHaskellCode -newtype Tuple = Tuple (Set (Name S))+newtype Tuple = Tuple (Set (Name ()))   deriving (Eq,Generic,Monoid,Show) instance Observable Tuple -instance Located Tuple where-  type LocType Tuple = S-  location f (Tuple names) = Tuple <$> location f names- isEmptyTuple :: Tuple -> Bool isEmptyTuple (Tuple t) = Set.null t  patternTuple :: Tuple -> Pat S patternTuple (Tuple [])  = PApp def (unit_con_name def) []-patternTuple (Tuple [x]) = PVar def x-patternTuple (Tuple t)   = PTuple def Boxed (map (PVar def) (Set.toList t))+patternTuple (Tuple [x]) = PVar def (const def <$> x)+patternTuple (Tuple t) =+  PTuple def Boxed (map (PVar def) (const def <$$> Set.toList t))  expTuple :: Tuple -> Exp S expTuple (Tuple [])  = unit_con def-expTuple (Tuple [t]) = Var def $ UnQual def t-expTuple (Tuple t)   = H.Tuple def Boxed (map (Var def . UnQual def) (Set.toList t))+expTuple (Tuple [t]) = Var def $ UnQual def (const def <$> t)+expTuple (Tuple t) =+  H.Tuple def Boxed (map (Var def . UnQual def) (const def <$$> Set.toList t))  emptyTuple :: Tuple emptyTuple = Tuple Set.empty unionTuple :: Tuple -> Tuple -> Tuple unionTuple (Tuple a) (Tuple b) = Tuple (a `Set.union` b) -minusTuple :: Tuple -> Set (Name S) -> Tuple+minusTuple :: Tuple -> Set (Name ()) -> Tuple Tuple t `minusTuple` vs = Tuple (t `Set.difference` vs)-intersectTuple :: Tuple -> Set (Name S) -> Tuple+intersectTuple :: Tuple -> Set (Name ()) -> Tuple intersectTuple = observe "intersectTuple" intersectTuple'-intersectTuple' :: Tuple -> Set (Name S) -> Tuple+intersectTuple' :: Tuple -> Set (Name ()) -> Tuple Tuple t `intersectTuple'` vs = Tuple (t `Set.intersection` vs)
src/ArrSyn.hs view
@@ -16,6 +16,7 @@  import           Control.Monad.Trans.State import           Control.Monad.Trans.Writer+import           Data.Default import           Data.List                  (mapAccumL) import           Data.Map                   (Map) import qualified Data.Map                   as Map@@ -140,7 +141,10 @@   anon (length ps) $ bind (definedVars ps) $ transCmd s' (foldl pairP p ps') c   where     (s', ps') = addVars' s ps-transCmd' _ _ x = error $ "transCmd: " ++ show x+transCmd' _ _ x = error $ "Invalid parse: " ++ showSrcLoc (H.fromSrcInfo $ getSrcSpanInfo $ ann x)+ where+  showSrcLoc :: H.SrcLoc -> String+  showSrcLoc (H.SrcLoc file line col) = file ++ ":" ++ show line ++ ":" ++ show col  -- transCmd' s p (CmdVar n) = --       arr (anonArgs a) (input s) p e >>> arrowExp (H.Var () (H.UnQual () n))@@ -201,12 +205,12 @@            p            rss'            (returnCmd-              (foldr (pair . H.Var l . H.UnQual l) output (Set.toList defined)))) `intersectTuple`+              (foldr (pair . H.Var l . H.UnQual l) output (const def <$$> Set.toList defined)))) `intersectTuple`       defined  data TransState = TransState {-      locals  :: Set (Name S),   -- vars in scope defined in this proc-      cmdVars :: Map (Name S) Arrow+      locals  :: Set (Name ()),   -- vars in scope defined in this proc+      cmdVars :: Map (Name ()) Arrow   } deriving (Eq, Generic, Show)  instance Observable TransState@@ -215,7 +219,7 @@ input s = Tuple (locals s)  addVars'-  :: (Observable a, AddVars a, Eq l, Show l, l ~ LocType a)+  :: (Observable a, AddVars a)   => TransState -> a -> (TransState, a) addVars' = observe "addVars" addVars
src/NewCode.hs view
@@ -11,7 +11,6 @@ import           Debug.Hoed.Pure import           GHC.Generics                  (Generic) import           Language.Haskell.Exts.Syntax-import           Language.Haskell.Exts.Util import           SrcLocs #ifdef DEBUG import           Language.Haskell.Exts.Observe ()@@ -51,8 +50,3 @@   deriving (Eq, Data, Ord, Generic, Show)  instance Observable Binding--instance Located Binding where-  type LocType Binding = Code-  location f (BindLet b)    = BindLet <$> location f b-  location f (BindCase p e) = BindCase <$> location f p <*> location f e
src/SrcLocs.hs view
@@ -8,9 +8,7 @@  -- | The type of src code locations used by arrowp-qq newtype S = S {getSrcSpanInfo :: SrcSpanInfo}-  deriving (Data, Typeable)-instance Eq S where _ == _ = True-instance Ord S where compare _ _ = EQ+  deriving (Eq, Ord, Data, Typeable) instance Show S where show _ = "<loc>"  instance Default S where
src/Utils.hs view
@@ -8,8 +8,7 @@ {-# LANGUAGE TypeFamilies        #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -Wno-orphans #-} module Utils-  ( HSE.Located(..)-  , S(..)+  ( S(..)   , HSE.rebracket1   , freeVars   , freeVarss@@ -55,29 +54,23 @@  freeVars   :: ( Observable a-     , Observable (Set (Name code))      , HSE.FreeVars a-     , code ~ HSE.LocType a      )-  => a -> Set (Name code)+  => a -> Set (Name ()) freeVars = observe "freeVars" HSE.freeVars  freeVarss   :: ( Observable a-     , Observable (Set (Name code))      , HSE.AllVars a-     , code ~ HSE.LocType a      )-  => a -> Set (Name code)+  => a -> Set (Name ()) freeVarss = observe "freeVarss" (HSE.free . HSE.allVars)  definedVars   :: ( Observable a-     , Observable (Set (Name code))      , HSE.AllVars a-     , code ~ HSE.LocType a      )-  => a -> Set (Name code)+  => a -> Set (Name ()) definedVars = observe "definedVars" (HSE.bound . HSE.allVars)  -- | Are a tuple pattern and an expression tuple equal ?@@ -103,13 +96,13 @@ times n f x = iterate f x !! n  -- | Hide variables from a pattern-hidePat :: Set (Name S) -> Pat S -> Pat S+hidePat :: Set (Name ()) -> Pat S -> Pat S hidePat vs = transform (go vs) where   go vs p@(PVar l n)-    | n `Set.member` vs = PWildCard l+    | void n `Set.member` vs = PWildCard l     | otherwise = p   go vs (PAsPat _ n p)-    | n `Set.member` vs = go vs p+    | void n `Set.member` vs = go vs p   go _ x = x  pair :: Exp code -> Exp code -> Exp code@@ -213,3 +206,4 @@ traverseAlt = descendBiM traverseAlts :: (Data s, Monad a) => (Exp s -> a(Exp s)) -> [Alt s] -> a [Alt s] traverseAlts = traverse.traverseAlt+