BiGUL 1.0.0 → 1.0.1
raw patch · 7 files changed
+221/−116 lines, 7 filesdep ~basedep ~template-haskell
Dependency ranges changed: base, template-haskell
Files
- BiGUL.cabal +12/−4
- CHANGELOG.md +24/−0
- src/Generics/BiGUL.hs +49/−38
- src/Generics/BiGUL/Error.hs +8/−5
- src/Generics/BiGUL/Interpreter.hs +23/−19
- src/Generics/BiGUL/Interpreter/Unsafe.hs +33/−31
- src/Generics/BiGUL/TH.hs +72/−19
BiGUL.cabal view
@@ -1,5 +1,5 @@ name: BiGUL-version: 1.0.0+version: 1.0.1 synopsis: The Bidirectional Generic Update Language description: Putback-based bidirectional programming allows the programmer to@@ -50,11 +50,19 @@ DeriveDataTypeable, FlexibleInstances, FlexibleContexts,- UndecidableInstances- build-depends: base == 4.8.*,+ UndecidableInstances,+ CPP+ if impl(ghc >= 7.10) && impl(ghc < 8)+ build-depends: base == 4.8.*, mtl >= 2.2, containers >= 0.5,- template-haskell >= 2.10,+ template-haskell >= 2.10 && < 2.11,+ th-extras >= 0.0.0.4+ else+ build-depends: base == 4.9.*,+ mtl >= 2.2,+ containers >= 0.5,+ template-haskell >= 2.11, th-extras >= 0.0.0.4 hs-source-dirs: src default-language: Haskell2010
CHANGELOG.md view
@@ -1,3 +1,27 @@+1.0.1 Changes+=============++* GHC 8.0.1 compabitility++ Generics.BiGUL.TH now works with template-haskell-2.11 (which is used by+ GHC 8.0.1). Also explanations of the GADT constructors in Generics.BiGUL+ have been included in the haddock documentation.++* `Generics.BiGUL.Checkpoint` added++ This new BiGUL constructor lets the programmer display a customised message+ in error traces.++* Error fixes++ - Fixed the glitch that normalSV does not convert boolean-valued lambdas to+ total functions.++ - Eliminated a “Pattern match(es) are overlapped” warning reported when+ using patterns as conditions.++ - Fixed a panic produced by `Generics.BiGUL.Interpreter.addCurrentBranchTrace`.+ 1.0.0 Changes =============
src/Generics/BiGUL.hs view
@@ -23,71 +23,82 @@ -- | This is the datatype of BiGUL programs, as a GADT indexed with the source and view types. -- Most of the types appearing in a BiGUL program should be instances of 'Show' to enable error reporting.+#if __GLASGOW_HASKELL__ >= 800+#define __DB__ |+#else -- Before GHC 8, haddock does not support documentation for GADT constructors; -- for GHC 7.10.*, see the source for the description of each constructor and its arguments.+#define __DB__+#endif data BiGUL s v where - -- Abort computation and emit an error message.+ -- __DB__ Abort computation and emit an error message. Fail :: String -- error message -> BiGUL s v - -- Keep the source unchanged, with the side condition that the view can be completely determined from the source.- -- Use Generics.BiGUL.Lib.skip when the view is a constant.+ -- __DB__ Keep the source unchanged, with the side condition that the view can be completely determined from the source.+ -- Use 'Generics.BiGUL.Lib.skip' when the view is a constant. Skip :: Eq v => (s -> v) -- how the view can be computed from the source -> BiGUL s v - -- Replace the source with the view (which should have the same type as the source).+ -- __DB__ Replace the source with the view (which should have the same type as the source). Replace :: BiGUL s s - -- When the source and view are both pairs, perform update on the first/second source and view components- -- using the first/second inner program.+ -- __DB__ When the source and view are both pairs, perform update on the first/second source and view components+ -- using the first/second inner program. Prod :: (Show s, Show s', Show v, Show v') => BiGUL s v -- program for updating the first components -> BiGUL s' v' -- program for updating the second components -> BiGUL (s, s') (v, v') - -- Rearrange the source into an intermediate form, which is updated by the inner program,- -- and then invert the rearrangement.- -- Instead of using 'RearrS' directly, use 'Generics.BiGUL.TH.rearrS' instead,- -- which offers a more intuitive syntax.- -- Note that the inner program should make sure that the updated source still- -- retains the intermediate form (so the inversion can succeed).+ -- __DB__ Rearrange the source into an intermediate form, which is updated by the inner program,+ -- and then invert the rearrangement.+ -- Instead of using 'RearrS' directly, use 'Generics.BiGUL.TH.rearrS' instead,+ -- which offers a more intuitive syntax.+ -- Note that the inner program should make sure that the updated source still+ -- retains the intermediate form (so the inversion can succeed). RearrS :: (Show s', Show v) => Pat s env con -- pattern for the original source -> Expr env s' -- expression computing the intermediate source -> BiGUL s' v -- program for updating the intermediate source -> BiGUL s v - -- Rearrange the view into a new one before continuing with the remaining program.- -- To guarantee well-behavedness, the expression should use all variables in the pattern.- -- Instead of using 'RearrV' directly, use 'Generics.BiGUL.TH.rearrV' instead,- -- which offers a more intuitive syntax and checks whether all pattern variables are used.+ -- __DB__ Rearrange the view into a new one before continuing with the remaining program.+ -- To guarantee well-behavedness, the expression should use all variables in the pattern.+ -- Instead of using 'RearrV' directly, use 'Generics.BiGUL.TH.rearrV' instead,+ -- which offers a more intuitive syntax and checks whether all pattern variables are used. RearrV :: (Show s, Show v') => Pat v env con -- pattern for the original view -> Expr env v' -- expression computing the new view -> BiGUL s v' -- remaining program -> BiGUL s v - -- When the view is a pair and the second component depends entirely on the first one,- -- discard the second component and continue with the remaining program.+ -- __DB__ When the view is a pair and the second component depends entirely on the first one,+ -- discard the second component and continue with the remaining program. Dep :: (Eq v', Show s, Show v) => (v -> v') -- how the second component of the view can be computed from the first -> BiGUL s v -- remaining program -> BiGUL s (v, v') - -- Case analysis on both the source and view.+ -- __DB__ Case analysis on both the source and view. Case :: [(s -> v -> Bool, CaseBranch s v)] -- branches, each of which consists of -- a main condition (on both the source and view) -- and an inner action -> BiGUL s v - -- Standard composition of bidirectional transformations.+ -- __DB__ Standard composition of bidirectional transformations. Compose :: (Show s, Show m, Show v) => BiGUL s m -> BiGUL m v -> BiGUL s v + -- __DB__ Display a programmer-supplied message prefixed with “checkpoint:” in error traces.+ Checkpoint :: (Show s, Show v)+ => String -- message to be emitted+ -> BiGUL s v -- remaining program+ -> BiGUL s v+ infixr 1 `Prod` infixr 1 `Compose` @@ -112,33 +123,33 @@ -- inverse evaluation of expressions. data Pat a env con where - -- Variable pattern, the value extracted from which can be duplicated.+ -- __DB__ Variable pattern, the value extracted from which can be duplicated. PVar :: Eq a => Pat a (Var a) (Maybe a) - -- Variable pattern, the value extracted from which cannot be duplicated.+ -- __DB__ Variable pattern, the value extracted from which cannot be duplicated. PVar' :: Pat a (Var a) (Maybe a) - -- Constant pattern.+ -- __DB__ Constant pattern. PConst :: Eq a => a -- constant to be matched -> Pat a () () - -- Product pattern.+ -- __DB__ Product pattern. PProd :: Pat a a' a'' -- left-hand side pattern -> Pat b b' b'' -- right-hand side pattern -> Pat (a, b) (a', b') (a'', b'') - -- Left pattern, matching values of shape `Left x :: Either a b` for some `x :: a`.+ -- __DB__ Left pattern, matching values of shape `Left x :: Either a b` for some `x :: a`. PLeft :: Pat a a' a'' -- inner pattern -> Pat (Either a b) a' a'' - -- Right pattern, matching values of shape `Right y :: Either a b` for some `y :: b`.+ -- __DB__ Right pattern, matching values of shape `Right y :: Either a b` for some `y :: b`. PRight :: Pat b b' b'' -- inner pattern -> Pat (Either a b) b' b'' - -- Constructor pattern, unwrapping a value to its sum-of-products representation.- -- (Invoke 'Generics.BiGUL.TH.deriveBiGULGenerics' on the datatype involved first.)+ -- __DB__ Constructor pattern, unwrapping a value to its sum-of-products representation.+ -- (Invoke 'Generics.BiGUL.TH.deriveBiGULGenerics' on the datatype involved first.) PIn :: InOut a => Pat (F a) b c -- inner pattern -> Pat a b c@@ -152,44 +163,44 @@ -- Their type is indexed by the environment type and the type of the variable position being pointed to. data Direction env a where - -- Point to the current variable position.+ -- __DB__ Point to the current variable position. DVar :: Direction (Var a) a - -- Point to the left part of the environment.+ -- __DB__ Point to the left part of the environment. DLeft :: Direction a t -> Direction (a, b) t - -- Point to the right part of the environment.+ -- __DB__ Point to the right part of the environment. DRight :: Direction b t -> Direction (a, b) t -- | Expressions are patterns whose variable positions contain directions pointing into some environment. -- Their type is indexed by the environment type and the type of the expressed value. data Expr env a where - -- Direction expression, referring to a value in the environment.+ -- __DB__ Direction expression, referring to a value in the environment. EDir :: Direction env a -> Expr env a - -- Constant expression.+ -- __DB__ Constant expression. EConst :: (Eq a) => a -- constant -> Expr env a - -- Product expression.+ -- __DB__ Product expression. EProd :: Expr env a -- left-hand side expression -> Expr env b -- right-hand side expression -> Expr env (a, b) - -- Left expression (producing an 'Either'-value).+ -- __DB__ Left expression (producing an 'Either'-value). ELeft :: Expr env a -> Expr env (Either a b) - -- Right expression (producing an 'Either'-value).+ -- __DB__ Right expression (producing an 'Either'-value). ERight :: Expr env b -> Expr env (Either a b) - -- Constructor expression, wrapping a sum-of-products representation into data.- -- (Invoke 'Generics.BiGUL.TH.deriveBiGULGenerics' on the datatype involved first.)+ -- __DB__ Constructor expression, wrapping a sum-of-products representation into data.+ -- (Invoke 'Generics.BiGUL.TH.deriveBiGULGenerics' on the datatype involved first.) EIn :: (InOut a) => Expr env (F a) -> Expr env a infixr 1 `EProd`
src/Generics/BiGUL/Error.hs view
@@ -67,13 +67,16 @@ | BEAdaptiveBranchMatched -- ^ The branch is adaptive and hence ignored. +indent :: String -> String+indent = unlines . map (" "++) . lines+ instance Show BiGULError where- show (BEFail str) = "fail statement executed\n " ++ str+ show (BEFail str) = "fail statement executed\n" ++ indent str show BESkipMismatch = "view not determined by the source"- show (BESourcePatternMismatch e) = "source pattern mismatch\n " ++ show e- show (BEViewPatternMismatch e) = "view pattern mismatch\n " ++ show e- show (BEInvRearrFailed e) = "inverse rearrangement failed\n " ++ show e- show (BEViewRecoveringFailed e) = "view recovering failed\n " ++ show e+ show (BESourcePatternMismatch e) = "source pattern mismatch\n" ++ indent (show e)+ show (BEViewPatternMismatch e) = "view pattern mismatch\n" ++ indent (show e)+ show (BEInvRearrFailed e) = "inverse rearrangement failed\n" ++ indent (show e)+ show (BEViewRecoveringFailed e) = "view recovering failed\n" ++ indent (show e) show BEDependencyMismatch = "second view component not determined by the first" show BECaseExhausted = "case exhausted" show BEAdaptiveBranchRevisited = "adaptive branch revisited"
src/Generics/BiGUL/Interpreter.hs view
@@ -52,7 +52,7 @@ addCurrentBranchTrace :: BiGULTrace -> BiGULTrace -> BiGULTrace addCurrentBranchTrace t (BTBranches ts) = BTBranches (t:ts)-addCurrentBranchTrace t _ = error "panic: Generics.BiGUL.Error.addCurrentBranchTrace"+addCurrentBranchTrace t u = u -- | The putback semantics of a 'Generics.BiGUL.BiGUL' program. put :: BiGUL s v -> s -> v -> Maybe s@@ -63,30 +63,32 @@ putTrace b s v = snd (runBiGULResult (putWithTrace b s v)) putWithTrace :: BiGUL s v -> s -> v -> BiGULResult s-putWithTrace (Fail str) s v = errorResult (BEFail str)-putWithTrace (Skip f) s v = if f s == v then return s else errorResult BESkipMismatch-putWithTrace Replace s v = return v-putWithTrace (l `Prod` r) (s, s') (v, v') =+putWithTrace (Fail str) s v = errorResult (BEFail str)+putWithTrace (Skip f) s v = if f s == v then return s else errorResult BESkipMismatch+putWithTrace Replace s v = return v+putWithTrace (l `Prod` r) (s, s') (v, v') = liftM2 (,) (modifyTrace (BTNextSV "on the left of Prod" s v ) (putWithTrace l s v )) (modifyTrace (BTNextSV "on the right of Prod" s' v') (putWithTrace r s' v'))-putWithTrace (RearrS p e b) s v = do+putWithTrace (RearrS p e b) s v = do env <- embedEither BESourcePatternMismatch (deconstruct p s) let m = eval e env s' <- modifyTrace (BTNextSV "inside RearrS" m v) (putWithTrace b m v) con <- embedEither BEInvRearrFailed (uneval p e s' (emptyContainer p)) return (construct p (fromContainerS p env con))-putWithTrace (RearrV p e b) s v = do+putWithTrace (RearrV p e b) s v = do v' <- embedEither BEViewPatternMismatch (deconstruct p v) let m = eval e v' modifyTrace (BTNextSV "inside RearrV" s m) (putWithTrace b s m)-putWithTrace (Dep f b) s (v, v') =+putWithTrace (Dep f b) s (v, v') = if f v == v' then modifyTrace (BTNextSV "inside Dep" s v) (putWithTrace b s v) else errorResult BEDependencyMismatch-putWithTrace (Case bs) s v = putCase bs s v-putWithTrace (l `Compose` r) s v = do+putWithTrace (Case bs) s v = putCase bs s v+putWithTrace (l `Compose` r) s v = do m <- modifyTrace (BTNextS "computing intermediate source" s) (getWithTrace l s) m' <- modifyTrace (BTNextSV "on the right of Compose" m v) (putWithTrace r m v) modifyTrace (BTNextSV "on the left of Compose" s m') (putWithTrace l s m')+putWithTrace (Checkpoint str b) s v =+ modifyTrace (BTNextSV ("checkpoint: " ++ str) s v) (putWithTrace b s v) getCaseBranch :: (s -> v -> Bool, CaseBranch s v) -> s -> BiGULResult v getCaseBranch (p, Normal b q) s =@@ -137,28 +139,30 @@ getTrace b s = snd (runBiGULResult (getWithTrace b s)) getWithTrace :: BiGUL s v -> s -> BiGULResult v-getWithTrace (Fail str) s = errorResult (BEFail str)-getWithTrace (Skip f) s = return (f s)-getWithTrace Replace s = return s-getWithTrace (l `Prod` r) (s, s') =+getWithTrace (Fail str) s = errorResult (BEFail str)+getWithTrace (Skip f) s = return (f s)+getWithTrace Replace s = return s+getWithTrace (l `Prod` r) (s, s') = liftM2 (,) (modifyTrace (BTNextS "on the left of Prod" s ) (getWithTrace l s )) (modifyTrace (BTNextS "on the right of Prod" s') (getWithTrace r s'))-getWithTrace (RearrS p e b) s = do+getWithTrace (RearrS p e b) s = do env <- embedEither BESourcePatternMismatch (deconstruct p s) let m = eval e env modifyTrace (BTNextS "inside RearrS" m) (getWithTrace b m)-getWithTrace (RearrV p e b) s = do+getWithTrace (RearrV p e b) s = do v' <- modifyTrace (BTNextS "inside RearrV" s) (getWithTrace b s) con <- embedEither BEInvRearrFailed (uneval p e v' (emptyContainer p)) env <- embedEither BEViewRecoveringFailed (fromContainerV p con) return (construct p env)-getWithTrace (Dep f b) s = do+getWithTrace (Dep f b) s = do v <- modifyTrace (BTNextS "inside Dep" s) (getWithTrace b s) return (v, f v)-getWithTrace (Case bs) s = getCase bs s-getWithTrace (l `Compose` r) s = do+getWithTrace (Case bs) s = getCase bs s+getWithTrace (l `Compose` r) s = do m <- modifyTrace (BTNextS "on the left of Compose" s) (getWithTrace l s) modifyTrace (BTNextS "on the right of Compose" m) (getWithTrace r m)+getWithTrace (Checkpoint str b) s =+ modifyTrace (BTNextS ("checkpoint: " ++ str) s) (getWithTrace b s) getCase :: [(s -> v -> Bool, CaseBranch s v)] -> s -> BiGULResult v getCase [] s = BiGULResult (Nothing, BTBranches [])
src/Generics/BiGUL/Interpreter/Unsafe.hs view
@@ -13,23 +13,24 @@ -- | The unsafe putback semantics of a 'Generics.BiGUL.BiGUL' program. put :: BiGUL s v -> s -> v -> s-put (Fail str) s v = error ("fail: " ++ str)-put (Skip f) s v = s-put Replace s v = v-put (l `Prod` r) (s, s') (v, v') = (put l s v, put r s' v')-put (RearrS p e b) s v = let env = fromRight (deconstruct p s)- m = eval e env- s' = put b m v- con = fromRight (uneval p e s' (emptyContainer p))- in construct p (fromContainerS p env con)-put (RearrV p e b) s v = let v' = fromRight (deconstruct p v)- m = eval e v'- in put b s m-put (Dep f b) s (v, v') = put b s v-put (Case bs) s v = putCase bs s v-put (l `Compose` r) s v = let m = get l s- m' = put r m v- in put l s m'+put (Fail str) s v = error ("fail: " ++ str)+put (Skip f) s v = s+put Replace s v = v+put (l `Prod` r) (s, s') (v, v') = (put l s v, put r s' v')+put (RearrS p e b) s v = let env = fromRight (deconstruct p s)+ m = eval e env+ s' = put b m v+ con = fromRight (uneval p e s' (emptyContainer p))+ in construct p (fromContainerS p env con)+put (RearrV p e b) s v = let v' = fromRight (deconstruct p v)+ m = eval e v'+ in put b s m+put (Dep f b) s (v, v') = put b s v+put (Case bs) s v = putCase bs s v+put (l `Compose` r) s v = let m = get l s+ m' = put r m v+ in put l s m'+put (Checkpoint _ b) s v = put b s v getCaseBranch :: (s -> v -> Bool, CaseBranch s v) -> s -> Maybe v getCaseBranch (p , Normal b q) s =@@ -52,20 +53,21 @@ -- | The unsafe get semantics of a 'Generics.BiGUL.BiGUL' program. get :: BiGUL s v -> s -> v-get (Fail str) s = error ("fail: " ++ str)-get (Skip f) s = f s-get Replace s = s-get (l `Prod` r) (s, s') = (get l s, get r s')-get (RearrS p e b) s = let env = fromRight (deconstruct p s)- m = eval e env- in get b m-get (RearrV p e b) s = let v' = get b s- con = fromRight (uneval p e v' (emptyContainer p))- env = fromRight (fromContainerV p con)- in construct p env-get (Dep f b) s = let v = get b s in (v, f v)-get (Case bs) s = getCase bs s-get (l `Compose` r) s = let m = get l s in get r m+get (Fail str) s = error ("fail: " ++ str)+get (Skip f) s = f s+get Replace s = s+get (l `Prod` r) (s, s') = (get l s, get r s')+get (RearrS p e b) s = let env = fromRight (deconstruct p s)+ m = eval e env+ in get b m+get (RearrV p e b) s = let v' = get b s+ con = fromRight (uneval p e v' (emptyContainer p))+ env = fromRight (fromContainerV p con)+ in construct p env+get (Dep f b) s = let v = get b s in (v, f v)+get (Case bs) s = getCase bs s+get (l `Compose` r) s = let m = get l s in get r m+get (Checkpoint _ b) s = get b s getCase :: [(s -> v -> Bool, CaseBranch s v)] -> s -> v getCase (pb@(p, b):bs) s =
src/Generics/BiGUL/TH.hs view
@@ -104,8 +104,18 @@ do info <- reify name case info of- (TyConI (DataD [] name typeVars constructors _)) -> return (name, typeVars, constructors)- (TyConI (NewtypeD [] name typeVars constructor _)) -> return (name, typeVars, [constructor])+#if __GLASGOW_HASKELL__ >= 800+ (TyConI (DataD [] name typeVars _ constructors _)) ->+#else+ (TyConI (DataD [] name typeVars constructors _)) ->+#endif+ return (name, typeVars, constructors)+#if __GLASGOW_HASKELL__ >= 800+ (TyConI (NewtypeD [] name typeVars _ constructor _)) ->+#else+ (TyConI (NewtypeD [] name typeVars constructor _)) ->+#endif+ return (name, typeVars, [constructor]) _ -> fail ("‘" ++ nameBase name ++ "’ is not in scope or not a (supported) datatype") ([nGeneric, nRep, nK1, nR, nU1, nSum, nProd, nV1, nS1, nSelector, nDataType], [vFrom, vTo, vK1, vL1, vR1, vU1, vProd, vSelName, vDataTypeName, vModuleName, vM1]) <-@@ -125,7 +135,11 @@ return $ catMaybes selectorDataDMaybeList ++ catMaybes (concat selectorDataTypeMaybeList) ++ catMaybes (concat selectorInstanceDecList) ++- [InstanceD []+ [InstanceD+#if __GLASGOW_HASKELL__ >= 800+ Nothing+#endif+ [] (AppT (ConT nGeneric) (generateTypeVarsType name typeVars)) [TySynInstD nRep (TySynEqn@@ -198,7 +212,12 @@ }) generateSelectorDataD :: [[Maybe Name]] -> [Maybe Dec]-generateSelectorDataD names = map (fmap (\n -> DataD [] n [] [] [])) (concat names)+generateSelectorDataD names =+#if __GLASGOW_HASKELL__ >= 800+ map (fmap (\n -> DataD [] n [] Nothing [] [])) (concat names)+#else+ map (fmap (\n -> DataD [] n [] [] [])) (concat names)+#endif -- Selector DataType Generation generateSelectorDataType :: Name -> Name -> Name -> String -> [Maybe Name] -> [Maybe Dec]@@ -207,11 +226,16 @@ generateSelectorDataType' :: Name -> Name -> Name -> String -> Maybe Name -> Maybe Dec generateSelectorDataType' nDataType vDataTypeName vModuleName moduleName (Just selectorName) =- Just $ InstanceD []- (AppT (ConT nDataType) (ConT selectorName))- [FunD vDataTypeName ([Clause [WildP] (NormalB (LitE (StringL (show selectorName)))) []]),- FunD vModuleName ([Clause [WildP] (NormalB (LitE (StringL moduleName))) []])- ]+ Just $+ InstanceD+#if __GLASGOW_HASKELL__ >= 800+ Nothing+#endif+ []+ (AppT (ConT nDataType) (ConT selectorName))+ [FunD vDataTypeName ([Clause [WildP] (NormalB (LitE (StringL (show selectorName)))) []]),+ FunD vModuleName ([Clause [WildP] (NormalB (LitE (StringL moduleName))) []])+ ] generateSelectorDataType' nDataType vDataTypeName vModuleName moduleName _ = Nothing -- Selector Instance Declaration generation@@ -221,9 +245,14 @@ generateSelectorInstanceDec' :: Name -> Name -> (Maybe Name, THS.VarStrictType) -> Maybe Dec generateSelectorInstanceDec' nSelector vSelName (Just selectorName, (name, _, _)) =- Just $ InstanceD []- (AppT (ConT nSelector) (ConT selectorName))- [FunD vSelName ([Clause [WildP] (NormalB (LitE (StringL (nameBase name)))) []])]+ Just $+ InstanceD+#if __GLASGOW_HASKELL__ >= 800+ Nothing+#endif+ []+ (AppT (ConT nSelector) (ConT selectorName))+ [FunD vSelName ([Clause [WildP] (NormalB (LitE (StringL (nameBase name)))) []])] generateSelectorInstanceDec' _ _ _ = Nothing -- generate type representation of polymorhpic type@@ -246,12 +275,21 @@ info <- reify conName datatypeName <- case info of+#if __GLASGOW_HASKELL__ >= 800+ DataConI _ _ n -> return n+#else DataConI _ _ n _ -> return n+#endif _ -> fail $ "‘" ++ nameBase conName ++ "’ is not a data constructor" typeInfo <- reify datatypeName let cons = case typeInfo of+#if __GLASGOW_HASKELL__ >= 800+ TyConI (DataD _ _ _ _ cons _) -> cons+ TyConI (NewtypeD _ _ _ _ con _) -> [con]+#else TyConI (DataD _ _ _ cons _) -> cons TyConI (NewtypeD _ _ _ con _) -> [con]+#endif _ -> [] return $ constructLRs (length cons) !! fromJust (List.findIndex (== conName) (map (\con -> case con of { NormalC n _ -> n; RecC n _ -> n}) cons))@@ -261,12 +299,21 @@ info <- reify conName datatypeName <- case info of+#if __GLASGOW_HASKELL__ >= 800+ DataConI _ _ n -> return n+#else DataConI _ _ n _ -> return n+#endif _ -> fail $ "‘" ++ nameBase conName ++ "’ is not a data constructor" typeInfo <- reify datatypeName let cons = case typeInfo of+#if __GLASGOW_HASKELL__ >= 800+ TyConI (DataD _ _ _ _ cons _) -> cons+ TyConI (NewtypeD _ _ _ _ con _) -> [con]+#else TyConI (DataD _ _ _ cons _) -> cons TyConI (NewtypeD _ _ _ con _) -> [con]+#endif _ -> [] return $ (\(RecC _ fs) -> length fs) (fromJust (List.find (\(RecC n _) -> n == conName) cons)) @@ -275,12 +322,21 @@ info <- reify conName datatypeName <- case info of+#if __GLASGOW_HASKELL__ >= 800+ DataConI _ _ n -> return n+#else DataConI _ _ n _ -> return n+#endif _ -> fail $ "‘" ++ nameBase conName ++ "’ is not a data constructor" typeInfo <- reify datatypeName let cons = case typeInfo of+#if __GLASGOW_HASKELL__ >= 800+ TyConI (DataD _ _ _ _ cons _) -> cons+ TyConI (NewtypeD _ _ _ _ con _) -> [con]+#else TyConI (DataD _ _ _ cons _) -> cons TyConI (NewtypeD _ _ _ con _) -> [con]+#endif _ -> [] case (List.findIndex (\(n,_,_) -> n == fieldName) ((\(RecC _ fs) -> fs) $ fromJust (List.find (\(RecC n _) -> n == conName) cons))) of Just res -> return res@@ -715,12 +771,8 @@ patCond :: TH.Pat -> Q TH.Exp patCond p = do- (_, [htrue,hfalse]) <- lookupNames "Prelude" [] ["True", "False"]- var <- newName "x"- return $ case p of- TH.WildP -> LamE [VarP var] (ConE htrue)- _ -> LamE [VarP var] (CaseE (VarE var)- [Match p (NormalB (ConE htrue)) [], Match WildP (NormalB (ConE hfalse)) []])+ (_, [htrue]) <- lookupNames "Prelude" [] ["True"]+ return (LamE [p] (ConE htrue)) nameAdaptive :: Q TH.Exp nameAdaptive = lookupNames astNamespace [] ["Adaptive"] >>= \(_, [badaptive]) -> conE badaptive@@ -793,7 +845,8 @@ -> c -- ^ exit condition (unary predicate on the source) -> Q TH.Exp normalSV mps mpv mq =- [|\b -> (\s v -> $(toExp mps) s && $(toExp mpv) v, $(nameNormal) b $(toExp mq >>= patLambdaToPred)) |]+ [| \b -> (\s v -> $(toExp mps >>= patLambdaToPred) s && $(toExp mpv >>= patLambdaToPred) v,+ $(nameNormal) b $(toExp mq >>= patLambdaToPred)) |] -- | Construct an adaptive branch, for which a main condition on the source and view should be specified. -- The usual way of using 'adaptive' is