diff --git a/BiGUL.cabal b/BiGUL.cabal --- a/BiGUL.cabal +++ b/BiGUL.cabal @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ============= diff --git a/src/Generics/BiGUL.hs b/src/Generics/BiGUL.hs --- a/src/Generics/BiGUL.hs +++ b/src/Generics/BiGUL.hs @@ -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` diff --git a/src/Generics/BiGUL/Error.hs b/src/Generics/BiGUL/Error.hs --- a/src/Generics/BiGUL/Error.hs +++ b/src/Generics/BiGUL/Error.hs @@ -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" diff --git a/src/Generics/BiGUL/Interpreter.hs b/src/Generics/BiGUL/Interpreter.hs --- a/src/Generics/BiGUL/Interpreter.hs +++ b/src/Generics/BiGUL/Interpreter.hs @@ -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 []) diff --git a/src/Generics/BiGUL/Interpreter/Unsafe.hs b/src/Generics/BiGUL/Interpreter/Unsafe.hs --- a/src/Generics/BiGUL/Interpreter/Unsafe.hs +++ b/src/Generics/BiGUL/Interpreter/Unsafe.hs @@ -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 = diff --git a/src/Generics/BiGUL/TH.hs b/src/Generics/BiGUL/TH.hs --- a/src/Generics/BiGUL/TH.hs +++ b/src/Generics/BiGUL/TH.hs @@ -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