packages feed

BiGUL 0.9.0.0 → 1.0.0

raw patch · 13 files changed

+1639/−828 lines, 13 filesdep +th-extrasdep −pretty

Dependencies added: th-extras

Dependencies removed: pretty

Files

BiGUL.cabal view
@@ -1,5 +1,5 @@ name:                BiGUL-version:             0.9.0.0+version:             1.0.0 synopsis:            The Bidirectional Generic Update Language description:   Putback-based bidirectional programming allows the programmer to@@ -26,15 +26,35 @@ category:            Language, Generics, Lenses build-type:          Simple cabal-version:       >=1.22+extra-source-files:  CHANGELOG.md  library-  exposed-modules:     Generics.BiGUL.AST+  exposed-modules:     Generics.BiGUL                        Generics.BiGUL.Error+                       Generics.BiGUL.PatternMatching                        Generics.BiGUL.Interpreter                        Generics.BiGUL.Interpreter.Unsafe                        Generics.BiGUL.TH+                       Generics.BiGUL.Lib+                       Generics.BiGUL.Lib.HuStudies+                       Generics.BiGUL.Lib.List   other-modules:       GHC.InOut-  default-extensions:  FlexibleInstances, KindSignatures, GADTs, TupleSections, TemplateHaskell, DeriveDataTypeable-  build-depends:       base >=4.8 && < 4.9, mtl >=2.2, pretty >=1.1, containers >=0.5, template-haskell >=2.10+  default-extensions:  TupleSections,+                       ViewPatterns,+                       GADTs,+                       TypeFamilies,+                       TypeOperators,+                       EmptyCase,+                       ExistentialQuantification,+                       TemplateHaskell,+                       DeriveDataTypeable,+                       FlexibleInstances,+                       FlexibleContexts,+                       UndecidableInstances+  build-depends:       base == 4.8.*,+                       mtl >= 2.2,+                       containers >= 0.5,+                       template-haskell >= 2.10,+                       th-extras >= 0.0.0.4   hs-source-dirs:      src   default-language:    Haskell2010
+ CHANGELOG.md view
@@ -0,0 +1,76 @@+1.0.0 Changes+=============++Version 1.0.0 is the first official release, and is *not* compatible with+0.9.0 and earlier development versions.++The targeted GHC version is 7.10; 8.0 support is postponed due to its+non–backward compatible revisions to Template Haskell.++* Module restructuring++    The module structure is refined and simplified, with `Generics.BiGUL.AST`+    changed to `Generics.BiGUL`, pattern matching functions extracted to+    `Generics.BiGUL.PatternMatching`, and `Generics.BiGUL.Lib` created to+    serve as a prelude. More specific library modules are placed under+    `Generics.BiGUL.Lib.`:++    - `Generics.BiGUL.Lib.List` is the place for list-processing library+      programs. For now the only inhabitant is the “BiFluX alignment”.++    - `Generics.BiGUL.Lib.HuStudies` contains some small, concrete examples+      illustrating the use of every BiGUL construct.++* `Generics.BiGUL.Skip` and `Generics.BiGUL.Dep` changed++    - The view type of `Skip` is not restricted to `()` anymore, but when+      skipping, the view should be determined by the source as specified by+      the new functional argument to `Skip` — we can perform `Skip f` on a+      source `s` if and only if the view is `f s`. The old `Skip` can be+      defined in terms of the new one as `Skip (const ())`. There is a helper+      function `skip = Skip . const` defined in `Generics.BiGUL.Lib`.++    - `Dep` has been reverted to the original version, used to ignore the+      second component of the view when it depends on the first (but not+      the source).++* Major changes to `Generics.BiGUL.TH`++    - `deriveBiGULGeneric` now supports `newtype`.++    - The `update` syntax now takes the source pattern as its first argument+      and the view pattern as its second argument. (Previously the view+      pattern comes first.)++    - `rearrV` and `update` now check at compile time whether all view+      information is used (forbidding wildcard in view patterns and requiring+      all view variables are used); also `rearrS` and `rearrV` check whether+      their first argument is a one-argument lambda-expression.++    - The branch construction syntax has been slimmed down to just four+      functions: `normal`, `normalSV`, `adaptive`, and `adaptiveSV`.++    - Normal branch constructing functions now take an additional argument+      specifying on the source an “exit condition”, which should be satisfied+      by the updated source after the branch body is executed. All the exit+      conditions in a `Case` statement should (ideally) be disjoint.+      Overlapping exit conditions are still allowed for fast prototyping,+      though — the putback semantics of 'Case' will compute successfully as+      long as the ranges of the branches are disjoint (regardless of whether+      the exit conditions are specified precisely enough).++* Error-reporting mechanism overhauled++    - The types of `put` and `get` from `Generics.BiGUL.Interpreter` are+      changed to produce simply `Maybe` results. When execution fails+      (producing `Nothing`), invoke `putTrace` and `getTrace` to see the+      exact failure and the execution trace leading to the failure.++    - The execution traces include intermediate sources and views; the types+      used in a BiGUL program are thus required to be instances of `Show`.++* Show instances for BiGUL programs removed++    There are two reasons: Functions, which are everywhere in BiGUL programs,+    cannot be shown; and worse, printing of recursive BiGUL programs will not+    terminate.
src/GHC/InOut.hs view
@@ -1,26 +1,57 @@-{-# LANGUAGE TypeFamilies, UndecidableInstances, FlexibleInstances, FlexibleContexts, TypeOperators #-}- ----------------------------------------------------------------------------- -- | -- Module      :  GHC.InOut -- Copyright   :  (C) 2013 Hugo Pacheco--- License     :  BSD-style (see the file LICENSE)+-- License     :  BSD-style (see below) -- Maintainer  :  Hugo Pacheco <hpacheco@nii.ac.jp> -- Stability   :  provisional -- -- Generic sums of products representation for algebraic data types---  -----+-- @+-- Copyright (c) 2013, National Institute of Informatics++-- All rights reserved.++-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:++--     * Redistributions of source code must retain the above copyright+--       notice, this list of conditions and the following disclaimer.++--     * Redistributions in binary form must reproduce the above+--       copyright notice, this list of conditions and the following+--       disclaimer in the documentation and/or other materials provided+--       with the distribution.++--     * The names of contributors may not be used to endorse or promote+--       products derived from this software without specific prior+--       written permission.++-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+-- @ ----------------------------------------------------------------------------+ module GHC.InOut where  import GHC.Generics + class (Generic a,ToFromRep (Rep a)) => InOut a where   inn :: F a -> a   out :: a -> F a-  + type family Flatten (f :: * -> *) :: * type F a = Flatten (Rep a) @@ -55,8 +86,3 @@ instance (Generic a,ToFromRep (Rep a)) => InOut a where   inn = to . toRep   out = fromRep . from----instance InOut [a] where---  inn s = either (\() -> []) (\(x,xs) -> x:xs) s---  out l = case l of { [] -> Left (); (x:xs) -> Right (x,xs) }-
+ src/Generics/BiGUL.hs view
@@ -0,0 +1,195 @@+-- | This is the main module defining the syntax of BiGUL.+--   "Generics.BiGUL.TH" provides some higher-level syntax for writing BiGUL programs.+--   See "Generics.BiGUL.Lib.HuStudies" for some small, illustrative examples.+--   To execute BiGUL programs, use 'Generics.BiGUL.Interpreter.put' and 'Generics.BiGUL.Interpreter.get'+--   from "Generics.BiGUL.Interpreter".++module Generics.BiGUL(+  -- * Main syntax+    BiGUL(..)+  , CaseBranch(..)+  -- * Rearrangement syntax+  -- | The following pattern and expression syntax for rearrangement operations are designed to be type-safe+  --   but not intended to be programmer-friendly. The programmer is expected to use the higher-level syntax+  --   from "Generics.BiGUL.TH", which desugars into the following raw syntax.+  --   For more detail about patterns and expressions, see "Generics.BiGUL.PatternMatching".+  , Pat(..)+  , Var(..)+  , Direction(..)+  , Expr(..)) where++import GHC.InOut+++-- | 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.+--   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.+data BiGUL s v where++  -- 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.+  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).+  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.+  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).+  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.+  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.+  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.+  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.+  Compose :: (Show s, Show m, Show v)+          => BiGUL s m+          -> BiGUL m v+          -> BiGUL s v++infixr 1 `Prod`+infixr 1 `Compose`++-- | A branch used in 'Case' (whose type is parametrised by the source and view types)+--   can be either 'Normal' or 'Adaptive'.+--   The exit conditions specified in 'Normal' branches should (ideally) be disjoint.+--   Overlapping exit conditions are still allowed for fast prototyping, though —+--   the putback semantics of 'Case' will compute successfully as long as the ranges+--   of the branches are disjoint (regardless of whether the exit conditions are+--   specified precisely enough).+data CaseBranch s v =+    -- | A 'Normal' branch contains an inner program, which should update the source such that+    --   both the main condition (on both the source and view) and the exit condition (on the source) are satisfied.+    Normal (BiGUL s v) (s -> Bool)+    -- | An 'Adaptive' branch contains an adaptation function, which should modify the source such that+    --   a 'Normal' branch is applicable.+  | Adaptive (s -> v -> s)+++-- | The datatype of patterns is indexed by three types: the type of values to which a pattern is applicable,+--   the type of environments resulting from pattern matching, and the type of containers used during+--   inverse evaluation of expressions.+data Pat a env con where++  -- 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.+  PVar'  :: Pat a (Var a) (Maybe a)++  -- Constant pattern.+  PConst :: Eq a+         => a  -- constant to be matched+         -> Pat a () ()++  -- 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`.+  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`.+  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.)+  PIn    :: InOut a+         => Pat (F a) b c  -- inner pattern+         -> Pat a b c++infixr 1 `PProd`++-- | A marker for variable positions in environment types.+newtype Var a = Var a deriving Show++-- | Directions point to a variable position (marked by 'Var') in an environment.+--   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.+  DVar    :: Direction (Var a) a++  -- Point to the left part of the environment.+  DLeft   :: Direction a t+          -> Direction (a, b) t++  -- 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.+  EDir   :: Direction env a+         -> Expr env a++  -- Constant expression.+  EConst :: (Eq a)+         => a  -- constant+         -> Expr env a++  -- 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).+  ELeft  :: Expr env a+         -> Expr env (Either a b)++  -- 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.)+  EIn    :: (InOut a) => Expr env (F a) -> Expr env a++infixr 1 `EProd`
− src/Generics/BiGUL/AST.hs 
@@ -1,227 +0,0 @@-module Generics.BiGUL.AST-  (BiGUL(..), CaseBranch(..), Pat(..), Direction(..), Expr(..),-   deconstruct, construct, eval, uneval, emptyContainer, fromContainerS, fromContainerV) where--import Generics.BiGUL.Error-import Control.Monad.Except-import GHC.InOut-import Data.List(intersperse)---data CaseBranch s v = Normal (BiGUL s v) (s -> Bool) | Adaptive (s -> v -> s)--instance Show (CaseBranch s v) where-  show (Normal bigul _) = "Normal " ++ show bigul-  show (Adaptive _    ) = "Adaptive <adaptive function>"--data BiGUL :: * -> * -> * where-  Fail    :: String -> BiGUL s v-  Skip    :: BiGUL s ()-  Replace :: BiGUL s s-  Prod    :: BiGUL s v -> BiGUL s' v' -> BiGUL (s, s') (v, v')-  RearrS  :: Pat s env con -> Expr env s' -> BiGUL s' v -> BiGUL s v-  RearrV  :: Pat v env con -> Expr env v' -> BiGUL s v' -> BiGUL s v-  Dep     :: (Eq v') => BiGUL s v -> (s -> v -> v') -> BiGUL s (v, v')-  Case    :: [(s -> v -> Bool, CaseBranch s v)] -> BiGUL s v-  Compose :: BiGUL s u -> BiGUL u v -> BiGUL s v--infixr 1 `Prod`--instance Show (BiGUL s v) where-  show (Fail s)  = "Fail: " ++ s-  show Skip      = "Skip"-  show Replace   = "Replace"-  show (Dep b _) = "(Dep <dependency function> " ++ show b ++ ")"-  show (Case bs) = "(Case [" ++ unwords (intersperse "\n" (map (\(_,b) -> "(predicate, " ++ show b ++ ")") bs)) ++ " ])"-  show _         = "Unknown BiGUL program in show"--newtype Var a = Var a--instance Show a => Show (Var a) where-  show (Var a) = "Var: " ++ show a---- Pat (view type) (environment type) (container type)-data Pat :: * -> * -> * -> * where-  PVar   :: Eq a => Pat a (Var a) (Maybe a)-  PVar'  :: Pat a (Var a) (Maybe a)-  PConst :: (Eq a) => a -> Pat a () ()-  PProd  :: Pat a a' a'' -> Pat b b' b'' -> Pat (a, b) (a', b') (a'', b'')-  PLeft  :: Pat a a' a'' -> Pat (Either a b) a' a''-  PRight :: Pat b b' b'' -> Pat (Either a b) b' b''-  PIn    :: InOut a => Pat (F a) b c -> Pat a b c--instance Show (Pat v e c) where-  show  PVar           = "PVar"-  show  PVar'          = "PVar'"-  show (PConst c)      = "PConst"-  show (PProd rp1 rp2) = "(PProd " ++ show rp1 ++ " " ++ show rp2 ++ ")"-  show (PLeft rp)      = "(PLeft " ++ show rp ++ ")"-  show (PRight rp)     = "(PRight " ++ show rp ++ ")"-  show (PIn rp)        = "(PIn " ++ show rp ++ ")"-  -- show _               = "show error in Pat"--deconstruct :: Pat a env con -> a -> Either (PatExprDirError a) env-deconstruct PVar              a          = return (Var a)-deconstruct PVar'             a          = return (Var a)-deconstruct (PConst c)        a          = if c == a then return () else throwError PEDConstantMismatch-deconstruct (PProd patl patr) (al, ar)   = liftM2 (,) (liftE PEDProdLeft  (deconstruct patl al))-                                                      (liftE PEDProdRight (deconstruct patr ar))-deconstruct (PLeft patl)      (Left  al) = liftE PEDEitherLeft  (deconstruct patl al)-deconstruct pat@(PLeft _)     a          = throwError PEDEitherMismatch-deconstruct (PRight patr)     (Right ar) = liftE PEDEitherRight (deconstruct patr ar)-deconstruct pat@(PRight _)    a          = throwError PEDEitherMismatch-deconstruct (PIn pat)         a          = liftE PEDIn (deconstruct pat (out a))--construct :: Pat a env con -> env -> a-construct PVar              (Var a)  = a-construct PVar'             (Var a)  = a-construct (PConst c)        _        = c-construct (PProd patl patr) (al, ar) = (construct patl al, construct patr ar)-construct (PLeft patl)      al       = Left  (construct patl al)-construct (PRight patr)     ar       = Right (construct patr ar)-construct (PIn pat)         a        = inn (construct pat a)--fromContainerV :: Pat v env con -> con -> Either (PatExprDirError v) env-fromContainerV PVar              Nothing      = throwError PEDValueUnrecoverable-fromContainerV PVar              (Just v)     = return (Var v)-fromContainerV PVar'             Nothing      = throwError PEDValueUnrecoverable-fromContainerV PVar'             (Just v)     = return (Var v)-fromContainerV (PConst c)        con          = return ()-fromContainerV (PProd patl patr) (conl, conr) = liftM2 (,) (liftE PEDProdLeft  (fromContainerV patl conl))-                                                           (liftE PEDProdRight (fromContainerV patr conr))-fromContainerV (PLeft pat)       con          = liftE PEDEitherLeft  (fromContainerV pat con)-fromContainerV (PRight pat)      con          = liftE PEDEitherRight (fromContainerV pat con)-fromContainerV (PIn pat)         con          = liftE PEDIn (fromContainerV pat con)--fromContainerS :: Pat s env con -> env -> con -> env-fromContainerS PVar              (Var s)     Nothing     = (Var s)-fromContainerS PVar              (Var s)     (Just s')   = (Var s')-fromContainerS PVar'             (Var s)     Nothing     = (Var s)-fromContainerS PVar'             (Var s)     (Just s')   = (Var s')-fromContainerS (PConst c)        _           _           = ()-fromContainerS (PProd lpat rpat) (env, env') (con, con') = (fromContainerS lpat env con, fromContainerS rpat env' con')-fromContainerS (PLeft pat)       env         con         = fromContainerS pat env con-fromContainerS (PRight pat)      env         con         = fromContainerS pat env con-fromContainerS (PIn pat)         env         con         = fromContainerS pat env con--emptyContainer :: Pat v env con -> con-emptyContainer PVar                = Nothing-emptyContainer PVar'               = Nothing-emptyContainer (PConst  c)         = ()-emptyContainer (PProd rpatl rpatr) = (emptyContainer rpatl, emptyContainer rpatr)-emptyContainer (PLeft pat        ) = emptyContainer pat-emptyContainer (PRight pat       ) = emptyContainer pat-emptyContainer (PIn  pat         ) = emptyContainer pat---- You need to explicitly specify the type arguments at the type level when using the Direction type.--- From type, you could know the type of the data you want.--- !comment: DMaybe did not used.-data Direction :: * -> * -> * where-  DVar    :: Direction (Var a) a-  DLeft   :: Direction a t -> Direction (a, b) t-  DRight  :: Direction b t -> Direction (a, b) t--instance Show (Direction a t) where-  show  DVar = "DVar"-  show (DLeft dir)  = "(DLeft " ++ show dir ++ ")"-  show (DRight dir) = "(DRight " ++ show dir ++ ")"--retrieve :: Direction a t -> a -> t-retrieve  DVar      (Var x) = x-retrieve (DLeft  p) (x, y)  = retrieve p x-retrieve (DRight p) (x, y)  = retrieve p y--data Expr :: * -> * -> * where-  EDir   :: Direction orig a -> Expr orig a-  EConst :: Eq a =>  a -> Expr orig a-  EIn    :: InOut a => Expr orig (F a) -> Expr orig a-  EProd  :: Expr orig a -> Expr orig b -> Expr orig (a, b)-  ELeft  :: Expr orig a -> Expr orig (Either a b)-  ERight :: Expr orig b -> Expr orig (Either a b)--instance Show (Expr orig a) where-  show (EDir dir)      = "(EDir " ++ show dir ++ ")"-  show (EConst c)      = "EConst"-  show (EProd e1 e2)   = "(EProd " ++ show e1 ++ " " ++ show e2 ++ ")"-  show (ELeft e)       = "(ELeft " ++ show e ++ ")"-  show (ERight e)      = "(ERight " ++ show e ++ ")"-  show (EIn e)         = "(EIn " ++ show e ++ ")"--eval :: Expr env a' -> env -> a'-eval (EDir dir)          env = retrieve dir env-eval (EConst c)          env = c-eval (EIn expr)          env = inn (eval expr env)-eval (EProd exprl exprr) env = (eval exprl env, eval exprr env)-eval (ELeft expr       ) env = Left $ eval expr env-eval (ERight expr      ) env = Right $ eval expr env---- The goal is to update the "Maybe" con to fill in proper values.--- con follow the structure of Pat--- we have updated value a', which follows the structure of Expr-uneval :: Pat a env con -> Expr env a' -> a' -> con -> Either (PatExprDirError a') con-uneval pat (EDir dir)          a'          con = unevalDir pat dir a' con-uneval pat (EConst c)          a'          con = if c == a' then return con else throwError PEDConstantMismatch-uneval pat (EIn expr)          a'          con = liftE PEDIn (uneval pat expr (out a') con)-uneval pat (EProd exprl exprr) (al', ar')  con = liftE PEDProdLeft (uneval pat exprl al' con) >>= liftE PEDProdRight . uneval pat exprr ar'-uneval pat (ELeft expr)        (Left al')  con = liftE PEDEitherLeft (uneval pat expr al' con)-uneval pat expr@(ELeft _)      a'          con = throwError PEDEitherMismatch-uneval pat (ERight expr)       (Right ar') con = liftE PEDEitherRight (uneval pat expr ar' con)-uneval pat expr@(ERight _)     a'          con = throwError PEDEitherMismatch--unevalDir :: Pat a env con -> Direction env a' -> a' -> con -> Either (PatExprDirError a') con-unevalDir PVar              DVar          a' (Just a'')   = if a' == a''-                                                            then return (Just a')-                                                            else throwError (PEDIncompatibleUpdates a' a'')-unevalDir PVar              DVar          a' Nothing      = return (Just a')-unevalDir PVar'             DVar          a' (Just a'')   = throwError (PEDMultipleUpdates a' a'')-unevalDir PVar'             DVar          a' Nothing      = return (Just a')-unevalDir (PConst c)        _             a' con          = return con-unevalDir (PProd patl patr) (DLeft dir)   a' (conl, conr) = liftM (, conr) (unevalDir patl dir a' conl)-unevalDir (PProd patl patr) (DRight dir)  a' (conl, conr) = liftM (conl ,) (unevalDir patr dir a' conr)-unevalDir (PLeft  patl    ) dir           a' con          = unevalDir patl dir a' con-unevalDir (PRight patr    ) dir           a' con          = unevalDir patr dir a' con-unevalDir (PIn pat        ) dir           a' con          = unevalDir pat  dir a' con---- TODO: static check of full embedding--- checkFullEmbed :: BiGUL m s v -> Bool--- checkFullEmbed Fail                    = True--- checkFullEmbed Skip                    = True--- checkFullEmbed Replace                 = True--- checkFullEmbed (RearrS pat expr bigul) = checkFullEmbed bigul--- checkFullEmbed (RearrV pat expr bigul) = checkRearr expr pat && checkFullEmbed bigul--- checkFullEmbed (Dep bigul f)           = checkFullEmbed bigul--- checkFullEmbed (Case branches)         = and (map checkBranch branches)---- checkBranch :: (s -> v -> Bool, CaseBranch m s v)  -> Bool--- checkBranch (cond, Normal bigul _) = checkFullEmbed bigul--- checkBranch (cond, _)              = True---- checkRearr :: Expr env v' -> Pat v env con -> Bool--- checkRearr expr pat = checkCon pat (abstractUpdateCon expr pat (emptyContainer pat))---- abstractUpdateCon :: Expr env a' -> Pat a env con -> con -> con--- abstractUpdateCon (EDir dir)          pat con = abstractUpdateDir pat dir con--- abstractUpdateCon (EConst c)          pat con = con--- abstractUpdateCon (EIn expr)          pat con = abstractUpdateCon expr pat con--- abstractUpdateCon (EProd exprl exprr) pat con = abstractUpdateCon exprr pat (abstractUpdateCon exprl pat con)--- abstractUpdateCon (ELeft expr)        pat con = abstractUpdateCon expr  pat con--- abstractUpdateCon (ERight expr)       pat con = abstractUpdateCon expr  pat con---- abstractUpdateDir :: Pat a env con -> Direction env a' -> con -> con--- abstractUpdateDir PVar              DVar         Nothing      = Just undefined--- abstractUpdateDir PVar              DVar         (Just _)     = Just undefined--- abstractUpdateDir (PConst c)        _            con          = con--- abstractUpdateDir (PProd patl patr) (DLeft dir)  (conl, conr) = (abstractUpdateDir patl dir conl, conr)--- abstractUpdateDir (PProd patl patr) (DRight dir) (conl, conr) = (conl, abstractUpdateDir patr dir conr)--- abstractUpdateDir (PLeft patl     ) dir          con          = abstractUpdateDir patl dir con--- abstractUpdateDir (PRight patr    ) dir          con          = abstractUpdateDir patr dir con--- abstractUpdateDir (PIn pat        ) dir          con          = abstractUpdateDir pat  dir con---- checkCon :: Pat v env con -> con -> Bool--- checkCon PVar               (Just _)     = True--- checkCon PVar               Nothing      = False--- checkCon (PConst c)         _            = True--- checkCon (PProd patl patr)  (conl, conr) = checkCon patl conl && checkCon patr conr--- checkCon (PLeft  patl)      con          = checkCon patl con--- checkCon (PRight patr)      con          = checkCon patr con--- checkCon (PIn pat    )      con          = checkCon pat  con
src/Generics/BiGUL/Error.hs view
@@ -1,191 +1,121 @@+-- | Datatypes for error traces, produced by the standard interpreters in "Generics.BiGUL.Interpreter".+ module Generics.BiGUL.Error where -import GHC.InOut-import Text.PrettyPrint+import Generics.BiGUL +import Control.Monad+import Data.List -class PrettyPrintable a where-  toDoc :: a -> Doc -data PutError :: * -> * -> * where-  PFail                      :: String -> PutError s v-  PSourcePatternMismatch     :: PatExprDirError s -> PutError s v-  PViewPatternMismatch       :: PatExprDirError v -> PutError s v-  PUnevalFailed              :: PatExprDirError s' -> PutError s v-  PDependencyMismatch        :: s -> PutError s (v, v')-  PNoIntermediateSource      :: GetError s v' -> PutError s v-  PCaseExhausted             :: PutError s v-  PAdaptiveBranchRevisited   :: PutError s v-  PAdaptiveBranchMatched     :: PutError s v-  PPreviousBranchMatched     :: PutError s v-  PBranchPredictionIncorrect :: PutError s v-  PPostVerificationFailed    :: PutError s v-  PBranchUnmatched           :: PutError s v-  ---  PProdLeft     :: s -> v -> PutError s v -> PutError (s, s') (v, v')-  PProdRight    :: s' -> v' -> PutError s' v' -> PutError (s, s') (v, v')-  PRearrS       :: s' -> v -> PutError s' v -> PutError s v-  PRearrV       :: s -> v' -> PutError s v' -> PutError s v-  PDep          :: s -> v -> PutError s v -> PutError s (v, v')-  PComposeLeft  :: a -> b -> PutError a b -> PutError a c-  PComposeRight :: b -> c -> PutError b c -> PutError a c-  PBranch       :: Int -> PutError s v -> PutError s v--incrBranchNo :: PutError s v -> PutError s v-incrBranchNo (PBranch i e) = PBranch (i+1) e-incrBranchNo e              = e--instance Show (PutError s v) where-  show (PFail str)                   = "fail: " ++ str-  show (PSourcePatternMismatch e)    = show e-  show (PViewPatternMismatch e)      = show e-  show (PUnevalFailed e)             = show e-  show (PDependencyMismatch _)       = "dependency mismatch"-  show (PNoIntermediateSource e)     = show e-  show  PCaseExhausted               = "case exhausted"-  show  PAdaptiveBranchRevisited     = "adaptive branch revisited"-  show  PAdaptiveBranchMatched       = "adaptive branch matched"-  show  PPreviousBranchMatched       = "previous branch matched"-  show  PBranchPredictionIncorrect   = "branch prediction incorrect"-  show  PPostVerificationFailed      = "post-verification failed"-  show  PBranchUnmatched             = "branch unmatched"-  show (PProdLeft _ _ e)             = show e-  show (PProdRight _ _ e)            = show e-  show (PRearrS _ _ e)               = show e-  show (PRearrV _ _ e)               = show e-  show (PDep _ _ e)                  = show e-  show (PComposeLeft _ _ e)          = show e-  show (PComposeRight _ _ e)         = show e-  show (PBranch _ e)                 = show e--indent :: Doc -> Doc-indent = nest 2--instance PrettyPrintable (PutError s v) where-  toDoc e@(PFail str)                = text (show e)-  toDoc (PSourcePatternMismatch e)   = text "source pattern mismatch" $+$ indent (toDoc e)-  toDoc (PViewPatternMismatch e)     = text "view pattern mismatch" $+$ indent (toDoc e)-  toDoc (PUnevalFailed e)            = text "inverse evaluation failed" $+$ indent (toDoc e)-  toDoc e@(PDependencyMismatch _)    = text (show e)-  toDoc (PNoIntermediateSource e)    = text "computation of intermediate source failed" $+$ indent (toDoc e)-  toDoc e@PCaseExhausted             = text (show e)-  toDoc e@PAdaptiveBranchRevisited   = text (show e)-  toDoc e@PAdaptiveBranchMatched     = text (show e)-  toDoc e@PPreviousBranchMatched     = text (show e)-  toDoc e@PBranchPredictionIncorrect = text (show e)-  toDoc e@PPostVerificationFailed    = text (show e)-  toDoc e@PBranchUnmatched           = text (show e)-  toDoc (PProdLeft _ _ e)            = text "on the left-hand side of Prod" $+$ toDoc e-  toDoc (PProdRight _ _ e)           = text "on the right-hand side of Prod" $+$ toDoc e-  toDoc (PRearrS _ _ e)              = text "in RearrS" $+$ toDoc e-  toDoc (PRearrV _ _ e)              = text "in RearrV" $+$ toDoc e-  toDoc (PDep _ _ e)                 = text "in Dep" $+$ toDoc e-  toDoc (PComposeLeft _ _ e)         = text "on the left-hand side of Comp" $+$ toDoc e-  toDoc (PComposeRight _ _ e)        = text "on the right-hand side of Comp" $+$ toDoc e-  toDoc (PBranch i e)                = text ("in Case branch " ++ show i) $+$ toDoc e--data GetError :: * -> * -> * where-  GFail                      :: String -> GetError s v-  GSourcePatternMismatch     :: PatExprDirError s -> GetError s v-  GUnevalFailed              :: PatExprDirError s' -> GetError s v-  GViewRecoveringIncomplete  :: PatExprDirError v' -> GetError s v-  GCaseExhausted             :: [GetError s v] -> GetError s v-  GPreviousBranchMatched     :: GetError s v-  GPostVerificationFailed    :: GetError s v-  GBranchUnmatched           :: GetError s v-  GAdaptiveBranchMatched     :: GetError s v-  ---  GProdLeft     :: s -> GetError s v -> GetError (s, s') (v, v')-  GProdRight    :: s' -> GetError s' v' -> GetError (s, s') (v, v')-  GRearrS       :: s' -> GetError s' v -> GetError s v-  GRearrV       :: s -> GetError s v' -> GetError s v-  GDep          :: s -> GetError s v -> GetError s (v, v')-  GComposeLeft  :: a -> GetError a b -> GetError a c-  GComposeRight :: b -> GetError b c -> GetError a c-  GBranch       :: Int -> GetError s v -> GetError s v--addCurrentBranchError :: GetError s v -> GetError s v -> GetError s v-addCurrentBranchError e0 (GCaseExhausted es) = GCaseExhausted (e0:es)-addCurrentBranchError e0 (GBranch i e) = GBranch (i+1) e--instance Show (GetError s v) where-  show (GFail str)                   = "fail: " ++ str-  show (GSourcePatternMismatch e)    = show e-  show (GUnevalFailed e)             = show e-  show (GViewRecoveringIncomplete e) = show e-  show (GCaseExhausted _)            = "case exhausted"-  show  GPreviousBranchMatched       = "previous branch matched"-  show  GPostVerificationFailed      = "post-verification failed"-  show  GBranchUnmatched             = "branch unmatched"-  show  GAdaptiveBranchMatched       = "adaptive branch matched"-  show (GProdLeft _ e)               = show e-  show (GProdRight _ e)              = show e-  show (GRearrS _ e)                 = show e-  show (GRearrV _ e)                 = show e-  show (GDep _ e)                    = show e-  show (GComposeLeft _ e)            = show e-  show (GComposeRight _ e)           = show e-  show (GBranch _ e)                 = show e+-- | Execution traces, which log the operations executed, intermediate sources and views, and reasons of eventual failure.+data BiGULTrace = BTSuccess+                    -- ^ Execution successfully produces a result.+                | BTError BiGULError+                    -- ^ Execution fails to produce a result.+                | forall s v. (Show s, Show v) => BTNextSV String s v BiGULTrace+                    -- ^ An intermediate step with the current source and view.+                | forall s. (Show s) => BTNextS String s BiGULTrace+                    -- ^ An intermediate step with the current source.+                | BTBranch Int BiGULTrace+                    -- ^ Inside a branch. /Notes that branch numbering starts from 0./+                | BTBranches [BiGULTrace]+                    -- ^ All branches fail. -instance PrettyPrintable (GetError s v) where-  toDoc e@(GFail str)                 = text (show e)-  toDoc (GSourcePatternMismatch e)    = text "source pattern mismatch" $+$ indent (toDoc e)-  toDoc (GUnevalFailed e)             = text "inverse evaluation failed" $+$ indent (toDoc e)-  toDoc (GViewRecoveringIncomplete e) = text "view recovering incomplete" $+$ indent (toDoc e)-  toDoc e@(GCaseExhausted es)         = text (show e) $+$-                                                foldr ($+$) empty-                                                  (zipWith (\i doc -> text ("branch " ++ show i) $+$ indent doc)-                                                           [0..]-                                                           (map toDoc es))-  toDoc e@GPreviousBranchMatched      = text (show e)-  toDoc e@GPostVerificationFailed     = text (show e)-  toDoc e@GBranchUnmatched            = text (show e)-  toDoc e@GAdaptiveBranchMatched      = text (show e)-  toDoc (GProdLeft _ e)               = text "on the left-hand side of Prod" $+$ toDoc e-  toDoc (GProdRight _ e)              = text "on the right-hand side of Prod" $+$ toDoc e-  toDoc (GRearrS _ e)                 = text "in RearrS" $+$ toDoc e-  toDoc (GRearrV _ e)                 = text "in RearrV" $+$ toDoc e-  toDoc (GDep _ e)                    = text "in Dep" $+$ toDoc e-  toDoc (GComposeLeft _ e)            = text "on the left-hand side of Comp" $+$ toDoc e-  toDoc (GComposeRight _ e)           = text "on the right-hand side of Comp" $+$ toDoc e-  toDoc (GBranch i e)                 = text ("in Case branch " ++ show i) $+$ toDoc e+instance Show BiGULTrace where+  show  BTSuccess           = "success"+  show (BTError e)          = show e+  show (BTNextSV str s v t) = str ++ "\n" +++                              "  source = " ++ show s ++ "\n" +++                              "  view   = " ++ show v ++ "\n" ++ show t+  show (BTNextS  str s   t) = str ++ "\n" +++                              "  source = " ++ show s ++ "\n" ++ show t+  show (BTBranch i t)       = "inside branch " ++ show i ++ "\n" ++ show t+  show (BTBranches ts)      = "all cases fail\n" +++                              concat (intersperse "\n" (concat+                                (zipWith (\i t -> ("  branch " ++ show i ++ ":") :+                                                  map ("    " ++) (lines (show t))) [0..] ts))) -data PatExprDirError :: * -> * where-  PEDConstantMismatch    :: PatExprDirError a-  PEDEitherMismatch   :: PatExprDirError (Either a b)-  PEDValueUnrecoverable  :: PatExprDirError a-  PEDIncompatibleUpdates :: a -> a -> PatExprDirError a-  PEDMultipleUpdates     :: a -> a -> PatExprDirError a-  ---  PEDProdLeft    :: PatExprDirError a -> PatExprDirError (a, b)-  PEDProdRight   :: PatExprDirError b -> PatExprDirError (a, b)-  PEDEitherLeft  :: PatExprDirError a -> PatExprDirError (Either a b)-  PEDEitherRight :: PatExprDirError b -> PatExprDirError (Either a b)-  PEDIn          :: InOut a => PatExprDirError (F a) -> PatExprDirError a+-- | Datatype of atomic errors.+data BiGULError = BEFail String+                    -- ^ 'Generics.BiGUL.Fail' is executed.+                | BESkipMismatch+                    -- ^ When executing @Skip f@ on a source @s@, the view is not @f s@.+                | BESourcePatternMismatch PatError+                    -- ^ The source does not match with a pattern.+                | BEViewPatternMismatch PatError+                    -- ^ The view does not match with a pattern.+                | BEInvRearrFailed PatError+                    -- ^ The inverse rearrangement fails.+                | BEViewRecoveringFailed PatError+                    -- ^ The view cannot be reconstructed.+                | BEDependencyMismatch+                    -- ^ When executing @Dep f _@ on a view pair @(v, v')@, the second component @v'@ is not @f v@.+                | BECaseExhausted+                    -- ^ No branch in a 'Generics.BiGUL.Case' statement is applicable.+                | BEAdaptiveBranchRevisited+                    -- ^ After adaptation, execution still goes into an adaptative branch.+                | BEPreviousBranchMatched+                    -- ^ After execution of a branch, the computed source and view+                    --   satisfy the main condition of a previous branch.+                | BEExitConditionFailed+                    -- ^ After execution of a branch, the updated source fails to satisfy the exit condition.+                | BEPostVerificationFailed+                    -- ^ After execution of a branch, the computed source and view do not satisfy the main condition.+                | BEBranchUnmatched+                    -- ^ The main condition is not satisfied by the source and view (and hence the branch is not chosen).+                | BEAdaptiveBranchMatched+                    -- ^ The branch is adaptive and hence ignored. -instance Show (PatExprDirError a) where-  show  PEDConstantMismatch         = "constant mismatch"-  show  PEDEitherMismatch           = "either value mismatch"-  show  PEDValueUnrecoverable       = "value unrecoverable"-  show (PEDIncompatibleUpdates _ _) = "incompatible updates"-  show (PEDMultipleUpdates _ _)     = "multiple updates"-  show (PEDProdLeft e)              = show e-  show (PEDProdRight e)             = show e-  show (PEDEitherLeft e)            = show e-  show (PEDEitherRight e)           = show e-  show (PEDIn e)                    = show e+instance Show BiGULError where+  show (BEFail str)                = "fail statement executed\n  " ++ 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  BEDependencyMismatch       = "second view component not determined by the first"+  show  BECaseExhausted            = "case exhausted"+  show  BEAdaptiveBranchRevisited  = "adaptive branch revisited"+  show  BEPreviousBranchMatched    = "previous branch matched after branch execution"+  show  BEExitConditionFailed      = "exit condition not satisfied after branch execution"+  show  BEPostVerificationFailed   = "main condition not satisfied after branch execution"+  show  BEBranchUnmatched          = "main condition not satisfied"+  show  BEAdaptiveBranchMatched    = "adaptive branch ignored" -instance PrettyPrintable (PatExprDirError a) where-  toDoc e@PEDConstantMismatch          = text (show e)-  toDoc e@PEDEitherMismatch            = text (show e)-  toDoc e@PEDValueUnrecoverable        = text (show e)-  toDoc e@(PEDIncompatibleUpdates _ _) = text (show e)-  toDoc e@(PEDMultipleUpdates _ _)     = text (show e)-  toDoc (PEDProdLeft e)                = text "on the left-hand side of PProd" $+$ toDoc e-  toDoc (PEDProdRight e)               = text "on the right-hand side of PProd" $+$ toDoc e-  toDoc (PEDEitherLeft e)              = text "inside PLeft" $+$ toDoc e-  toDoc (PEDEitherRight e)             = text "inside PRight" $+$ toDoc e-  toDoc (PEDIn e)                      = text "inside PIn" $+$ toDoc e+-- | Pattern matching errors, which also explain where the matching fails.+data PatError = PEConstantMismatch+                  -- ^ A constant pattern/expression is matched with a different value.+              | PELeftMismatch+                  -- ^ A 'Left' pattern/expression is matched with a 'Right' value.+              | PERightMismatch+                  -- ^ A 'Right' pattern/expression is matched with a 'Left' value.+              | PEIncompatibleUpdates+                  -- ^ Occurrences of the same variable in an expression are matched with different values.+              | PEMultipleUpdates+                  -- ^ A variable that should appear at most once in an expression is however used multiple times.+              | PEValueUnrecoverable+                  -- ^ A variable that should appear at least once in an expression is however absent.+              | PEProdL PatError+                  -- ^ The error is on the left of a product pattern/expression.+              | PEProdR PatError+                  -- ^ The error is on the right of a product pattern/expression.+              | PELeft  PatError+                  -- ^ The error is inside a 'Left' pattern/expression.+              | PERight PatError+                  -- ^ The error is inside a 'Right' pattern/expression.+              | PEIn    PatError+                  -- ^ The error is inside a constructor pattern/expression. -liftE :: (a -> b) -> Either a c -> Either b c-liftE f = either (Left . f) Right+instance Show PatError where+  show  PEConstantMismatch    = "matching a constant pattern/expression with a different value"+  show  PELeftMismatch        = "matching a Left pattern/expression with a Right value"+  show  PERightMismatch       = "matching a Right pattern/expression with a Left value"+  show  PEIncompatibleUpdates = "matching occurrences of the same variable with different values"+  show  PEMultipleUpdates     = "multiple occurrences of a variable that can only be used at most once"+  show  PEValueUnrecoverable  = "no occurrences of a variable that should be used at least once"+  show (PEProdL e)            = "on the left of a product pattern/expression\n" ++ show e+  show (PEProdR e)            = "on the right of a product pattern/expression\n" ++ show e+  show (PELeft  e)            = "inside a Left pattern/expression\n" ++ show e+  show (PERight e)            = "inside a Right pattern/expression\n" ++ show e+  show (PEIn    e)            = "inside a constructor pattern/expression\n" ++ show e
src/Generics/BiGUL/Interpreter.hs view
@@ -1,109 +1,170 @@-module Generics.BiGUL.Interpreter (put, get, PutResult, GetResult, errorTrace) where+-- | The standard interpreters, which perform all dynamic checks to ensure well-behavedness+--   and produce trace information when execution fails.+--   Currently, tracing is designed for debugging, and only the traces leading to failure+--   can be expected to contain a complete log of the steps executed.+--   In other words, traces leading to success usually contain only partial tracing information.+--   Also, when a program loops, there is no guarantee that the trace is computed productively.+--   Finally, /note that branch numbering starts from 0./ +module Generics.BiGUL.Interpreter (put, putTrace, get, getTrace) where++import Generics.BiGUL import Generics.BiGUL.Error-import Generics.BiGUL.AST-import Control.Monad.Except-import Text.PrettyPrint+import Generics.BiGUL.PatternMatching +import Control.Monad -errorTrace :: PrettyPrintable e => Either e a -> Either Doc a-errorTrace = either (Left . (text "error" $+$) . toDoc) Right -catchBind :: Either e a -> (a -> Either e b) -> (e -> Either e b) -> Either e b-catchBind ma f g = either g f ma+-- | A 'Maybe' monad with/modulo trace information —+--   the monad laws hold only when the trace component is /not/ considered.+newtype BiGULResult a = BiGULResult { runBiGULResult :: (Maybe a, BiGULTrace) } -type PutResult s v = Either (PutError s v) s+instance Functor BiGULResult where+    fmap = liftM -put :: BiGUL s v -> s -> v -> PutResult s v-put (Fail str)              s       v       = throwError (PFail str)-put Skip                    s       v       = return s-put Replace                 s       v       = return v-put (Prod bigul bigul')     (s, s') (v, v') = liftM2 (,) (liftE (PProdLeft  s  v ) (put bigul  s  v ))-                                                         (liftE (PProdRight s' v') (put bigul' s' v'))-put (RearrS pat expr bigul) s       v       = do env <- liftE PSourcePatternMismatch (deconstruct pat s)-                                                 let m = eval expr env-                                                 s'  <- liftE (PRearrS m v) (put bigul m v)-                                                 con <- liftE PUnevalFailed (uneval pat expr s' (emptyContainer pat))-                                                 return (construct pat (fromContainerS pat env con))-put (RearrV pat expr bigul) s       v       = do v' <- liftE PViewPatternMismatch (deconstruct pat v)-                                                 let m = eval expr v'-                                                 liftE (PRearrV s m) (put bigul s m)-put (Dep bigul f)           s       (v, v') = do s' <- liftE (PDep s v) (put bigul s v)-                                                 if f s' v == v'-                                                 then return s'-                                                 else throwError (PDependencyMismatch s')-put (Case branches)         s       v       = putCase branches s v-put (Compose bigul bigul')  s       v       = do m  <- liftE PNoIntermediateSource (get bigul s)-                                                 m' <- liftE (PComposeRight m v) (put bigul' m v)-                                                 liftE (PComposeLeft s m') (put bigul s m')+instance Applicative BiGULResult where+  pure x = BiGULResult (Just x, BTSuccess)+  (<*>)  = ap -getCaseBranch :: (s -> v -> Bool, CaseBranch s v) -> s -> GetResult s v-getCaseBranch (p , Normal bigul q) s =+instance Monad BiGULResult where+  return = pure+  BiGULResult (Just x , t) >>= f = f x+  BiGULResult (Nothing, t) >>= f = BiGULResult (Nothing, t)++-- Auxiliary functions for 'BiGULResult'.++catchBind :: BiGULResult a -> (a -> BiGULResult b) -> (BiGULTrace -> BiGULResult b) -> BiGULResult b+catchBind (BiGULResult (Just x , _)) f g = f x+catchBind (BiGULResult (Nothing, t)) f g = g t++errorResult :: BiGULError -> BiGULResult a+errorResult e = BiGULResult (Nothing, BTError e)++modifyTrace :: (BiGULTrace -> BiGULTrace) -> BiGULResult a -> BiGULResult a+modifyTrace f (BiGULResult ~(mx, t)) = BiGULResult (mx, f t)++embedEither :: (e -> BiGULError) -> Either e a -> BiGULResult a+embedEither f = either (errorResult . f) return++incrBranchNo :: BiGULTrace -> BiGULTrace+incrBranchNo (BTBranch i t) = BTBranch (i+1) t+incrBranchNo t              = t++addCurrentBranchTrace :: BiGULTrace -> BiGULTrace -> BiGULTrace+addCurrentBranchTrace t (BTBranches ts) = BTBranches (t:ts)+addCurrentBranchTrace t _               = error "panic: Generics.BiGUL.Error.addCurrentBranchTrace"++-- | The putback semantics of a 'Generics.BiGUL.BiGUL' program.+put :: BiGUL s v -> s -> v -> Maybe s+put b s v = fst (runBiGULResult (putWithTrace b s v))++-- | The execution trace of a 'put' computation.+putTrace :: BiGUL s v -> s -> v -> BiGULTrace+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') =+  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+  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+  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') =+  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+  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')++getCaseBranch :: (s -> v -> Bool, CaseBranch s v) -> s -> BiGULResult v+getCaseBranch (p, Normal b q) s =   if q s-  then do v <- get bigul s+  then do v <- getWithTrace b s           if p s v           then return v-          else throwError GPostVerificationFailed-  else throwError GBranchUnmatched-getCaseBranch (p , Adaptive f)     s = throwError GAdaptiveBranchMatched+          else errorResult BEPostVerificationFailed+  else errorResult BEBranchUnmatched+getCaseBranch (p, Adaptive f) s = errorResult BEAdaptiveBranchMatched -putCaseCheckDiversion :: [(s -> v -> Bool, CaseBranch s v)] -> s -> v -> Either (PutError s v) ()+putCaseCheckDiversion :: [(s -> v -> Bool, CaseBranch s v)] -> s -> v -> BiGULResult () putCaseCheckDiversion []             s v = return () putCaseCheckDiversion (pb@(p, b):bs) s v =   if not (p s v)-  then catchBind (liftE (const undefined) (getCaseBranch pb s))-                 (const (throwError PPreviousBranchMatched))-                 (const (putCaseCheckDiversion bs s v))-  else throwError PPreviousBranchMatched+  then catchBind (getCaseBranch pb s) (const (errorResult BEPreviousBranchMatched))+                                      (const (putCaseCheckDiversion bs s v))+  else errorResult BEPreviousBranchMatched  putCaseWithAdaptation :: [(s -> v -> Bool, CaseBranch s v)] -> [(s -> v -> Bool, CaseBranch s v)] ->-                         s -> v -> (s -> PutResult s v) -> PutResult s v-putCaseWithAdaptation []             bs' s v cont = throwError PCaseExhausted+                         s -> v -> (s -> BiGULResult s) -> BiGULResult s+putCaseWithAdaptation []             bs' s v cont = errorResult BECaseExhausted putCaseWithAdaptation (pb@(p, b):bs) bs' s v cont =   if p s v-  then liftE (PBranch 0) $+  then modifyTrace (BTBranch 0) $        case b of-         Normal bigul q -> do-           s' <- put bigul s v+         Normal b q -> do+           s' <- putWithTrace b s v            if p s' v            then if q s'                 then putCaseCheckDiversion bs' s' v >> return s'-                else throwError PBranchPredictionIncorrect-           else throwError PPostVerificationFailed+                else errorResult BEExitConditionFailed+           else errorResult BEPostVerificationFailed          Adaptive f -> cont (f s v)-  else liftE incrBranchNo (putCaseWithAdaptation bs (pb:bs') s v cont)+  else modifyTrace incrBranchNo (putCaseWithAdaptation bs (pb:bs') s v cont) -putCase :: [(s -> v -> Bool, CaseBranch s v)] -> s -> v -> Either (PutError s v) s+putCase :: [(s -> v -> Bool, CaseBranch s v)] -> s -> v -> BiGULResult s putCase bs s v = putCaseWithAdaptation bs [] s v                    (\s' -> putCaseWithAdaptation bs [] s' v-                             (const (throwError PAdaptiveBranchRevisited)))+                             (const (errorResult BEAdaptiveBranchRevisited))) -type GetResult s v = Either (GetError s v) v+-- | The get semantics of a 'Generics.BiGUL.BiGUL' program.+get :: BiGUL s v -> s -> Maybe v+get b s = fst (runBiGULResult (getWithTrace b s)) -get :: BiGUL s v -> s -> GetResult s v-get (Fail str)              s       = throwError (GFail str)-get Skip                    s       = return ()-get Replace                 s       = return s-get (Prod bigul bigul')     (s, s') = liftM2 (,) (liftE (GProdLeft  s ) (get bigul  s ))-                                                 (liftE (GProdRight s') (get bigul' s'))-get (RearrS pat expr bigul) s       = do env <- liftE GSourcePatternMismatch (deconstruct pat s)-                                         let m = eval expr env-                                         liftE (GRearrS m) (get bigul m)-get (RearrV pat expr bigul) s       = do v'  <- liftE (GRearrV s) (get bigul s)-                                         con <- liftE GUnevalFailed (uneval pat expr v' (emptyContainer pat))-                                         env <- liftE GViewRecoveringIncomplete (fromContainerV pat con)-                                         return (construct pat env)-get (Dep bigul f)           s       = do v <- liftE (GDep s) (get bigul s)-                                         return (v, f s v)-get (Case branches)         s       = getCase branches s-get (Compose bigul bigul')  s       = do m <- liftE (GComposeLeft s) (get bigul s)-                                         liftE (GComposeRight m) (get bigul' m)+-- | The execution trace of a 'get' computation.+getTrace :: BiGUL s v -> s -> BiGULTrace+getTrace b s = snd (runBiGULResult (getWithTrace b s)) -getCase :: [(s -> v -> Bool, CaseBranch s v)] -> s -> GetResult s v-getCase []             s = throwError (GCaseExhausted [])+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') =+  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+  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+  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+  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+  m <- modifyTrace (BTNextS "on the left of Compose" s) (getWithTrace l s)+  modifyTrace (BTNextS "on the right of Compose" m) (getWithTrace r m)++getCase :: [(s -> v -> Bool, CaseBranch s v)] -> s -> BiGULResult v+getCase []             s =  BiGULResult (Nothing, BTBranches []) getCase (pb@(p, b):bs) s =   catchBind (getCaseBranch pb s) return-            (\e -> do v <- liftE (addCurrentBranchError e) (getCase bs s)+            (\t -> do v <- modifyTrace (addCurrentBranchTrace t) (getCase bs s)                       if not (p s v)                       then return v-                      else throwError (GBranch 0 GPreviousBranchMatched))+                      else modifyTrace (BTBranch 0) (errorResult BEPreviousBranchMatched))
src/Generics/BiGUL/Interpreter/Unsafe.hs view
@@ -1,67 +1,71 @@+-- | The unsafe interpreters, which assume that computation always succeeds and omit all dynamic checking.+--   Use these interpreters only when you have ensured that your 'Generics.BiGUL.BiGUL' program is correct.+ module Generics.BiGUL.Interpreter.Unsafe (put, get) where -import Generics.BiGUL.AST+import Generics.BiGUL+import Generics.BiGUL.PatternMatching   fromRight :: Either a b -> b fromRight (Right b) = b fromRight _         = error "fromRight fails" +-- | The unsafe putback semantics of a 'Generics.BiGUL.BiGUL' program. put :: BiGUL s v -> s -> v -> s-put (Fail err)              s       v       = error ("fail: " ++ err)-put Skip                    s       v       = s-put Replace                 s       v       = v-put (Prod bigul bigul')     (s, s') (v, v') = (put bigul s v, put bigul' s' v')-put (RearrS pat expr bigul) s       v       = let env = fromRight (deconstruct pat s)-                                                  m   = eval expr env-                                                  s'  = put bigul m v-                                                  con = fromRight (uneval pat expr s' (emptyContainer pat))-                                              in  construct pat (fromContainerS pat env con)-put (RearrV pat expr bigul) s       v       = let v' = fromRight (deconstruct pat v)-                                                  m  = eval expr v'-                                              in  put bigul s m-put (Dep bigul f)           s       (v, v') = put bigul s v-put (Case branches)         s       v       = putCase branches s v-put (Compose bigul bigul')  s       v       = let m  = get bigul s-                                                  m' = put bigul' m v-                                              in  put bigul 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'  getCaseBranch :: (s -> v -> Bool, CaseBranch s v) -> s -> Maybe v-getCaseBranch (p , Normal bigul q) s =+getCaseBranch (p , Normal b q) s =   if q s-  then let v = get bigul s+  then let v = get b s        in  if p s v then Just v else Nothing   else Nothing-getCaseBranch (p , Adaptive f)     s = Nothing+getCaseBranch (p , Adaptive f) s = Nothing  putCaseWithAdaptation :: [(s -> v -> Bool, CaseBranch s v)] -> s -> v -> (s -> s) -> s putCaseWithAdaptation (pb@(p, b):bs) s v cont =   if p s v   then case b of-         Normal bigul q -> put bigul s v+         Normal b q -> put b s v          Adaptive f     -> cont (f s v)   else putCaseWithAdaptation bs s v cont  putCase :: [(s -> v -> Bool, CaseBranch s v)] -> s -> v -> s putCase bs s v = putCaseWithAdaptation bs s v (\s' -> putCase bs s' v) +-- | The unsafe get semantics of a 'Generics.BiGUL.BiGUL' program. get :: BiGUL s v -> s -> v-get (Fail err)              s       = error ("fail: " ++ err)-get Skip                    s       = ()-get Replace                 s       = s-get (Prod bigul bigul')     (s, s') = (get bigul s, get bigul' s')-get (RearrS pat expr bigul) s       = let env = fromRight (deconstruct pat s)-                                          m   = eval expr env-                                      in  get bigul m-get (RearrV pat expr bigul) s       = let v'  = get bigul s-                                          con = fromRight (uneval pat expr v' (emptyContainer pat))-                                          env = fromRight (fromContainerV pat con)-                                      in  construct pat env-get (Dep bigul f)           s       = let v = get bigul s-                                      in  (v, f s v)-get (Case branches)         s       = getCase branches s-get (Compose bigul bigul')  s       = let m = get bigul s-                                      in  get bigul' 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  getCase :: [(s -> v -> Bool, CaseBranch s v)] -> s -> v getCase (pb@(p, b):bs) s =
+ src/Generics/BiGUL/Lib.hs view
@@ -0,0 +1,26 @@+-- | A prelude for BiGUL programs.++module Generics.BiGUL.Lib where++import Generics.BiGUL+import Generics.BiGUL.TH+++-- | Skip updating the source when the view is known to be a constant. Same as @Skip . const@.+skip :: Eq v => v -> BiGUL s v+skip v = Skip (const v)++-- | A nicer notation for applying a branch constructing function to a branch body. Same as 'Prelude.$'.+(==>) :: (a -> b) -> a -> b+(==>) = ($)++infixr 0 ==>++-- | Embed a well-behaved pair of transformations into BiGUL.+emb :: Eq v => (s -> v) -> (s -> v -> s) -> BiGUL s v+emb g p = Case+  [ $(normal [| \s v -> g s == v |] [p| _ |])+    ==> Skip g+  , $(adaptive [| \s v -> {- g s /= v -} True |])+    ==> p+  ]
+ src/Generics/BiGUL/Lib/HuStudies.hs view
@@ -0,0 +1,468 @@+-- | The module contains many examples, from easy to difficult, showing how to program in BiGUL.++module Generics.BiGUL.Lib.HuStudies where++import Generics.BiGUL+import Generics.BiGUL.Interpreter+import Generics.BiGUL.TH++-- |+-- > alwaysFail = Fail "always fail"+-- the combinator 'Fail' will always fail all the transformation, reporting the given error message.+--+-- >>> get alwaysFail "Please succeed"+-- Left fail: always fail+-- >>> put alwaysFail 23 False+-- Left fail: always fail+alwaysFail :: BiGUL a b+alwaysFail = Fail "always fail"+++-- |+-- > constSquare = Skip (\s -> s * s)+-- (Skip f) means that in the get direction, the view is fully computed by apply function f to the source.+-- So in the put direction, the update is skipped and the source is unchanged.+-- in the put direction, if (f source) /= view, an error is raised.+-- the view is the square of the source.+--+-- >>> put constSquare 10 100+-- Right 10+--+-- >>> put constSquare 10 225+-- Left *** Exception blabla...+--+-- >>> get constSquare 5+-- Right 25+constSquare :: BiGUL Int Int+constSquare = Skip (\s -> s * s)+++-- |+-- > repFirst = Replace `Prod` Skip (const ())+-- the example shows a simplest case to chain basic constructors of BiGUL together.+-- 'Prod' is right associative with priority 1 (0 is the lowest, e.g. $ is 0)+-- To use 'Prod', the source and view are assumed to be tuple.+-- the first elements of both tuples are associated by 'Replace', the second by 'Skip'.+--+-- >>> put repFirst (False, 9) (True, ())+-- Right (True,9)+--+-- >>> get repFirst (True, 3)+-- Right (True,())+repFirst :: (Show a, Show b) => BiGUL (a, b) (a, ())+repFirst = Replace `Prod` Skip (const ())+++-- |+-- > repFirst' = $(update [p| (x,_) |] [p| (x,()) |] [d| x = Replace |])+-- This is the 'repFirst' example rewritten with syntactic sugar.+-- The syntax is+--+-- > $(update [p| source-pattern |] [p| view-pattern |] [d| updating-strategy |])+-- Source and view are decomposed by the patterns in the [p| ... |].+-- In this concrete example, the first elements of the tuple (both in the source and in the viwe) are bound to variable x,+-- and they are sent to the combinator 'Replace' as arguments by (/x=Replace/) in the [d| ... |] part.+-- anything we want to perform 'Skip' should be marked as underline(_) in the [p| source-pattern |] and it should not appear in the [d| ... |] part.+--+-- The source-pattern and view-pattern can be very different, for example:+--+-- > $([p| Left x : _  |] [p| ((), x) |] [d| x = blabla... |])+-- where the source-pattern stands for a non-empty list of Either type, and we bind variable x to the inner part of the Left constructor.+-- However the view is a tuple, and we bind the second element to x.+-- The rearrangement for source and view is automatically done.+repFirst' :: Show a => BiGUL (a, b) (a, ())+repFirst' = $(update [p| (x,_) |] [p| (x,()) |] [d| x = Replace |])++++-- |+-- > repFirstV2 = RearrV PVar' (EDir DVar `EProd` EConst ()) repFirst+-- Skip to 'repFirstV2'' if you want to use the syntactic sugar only.+--+-- In the previous example, suppose what we really want is that, the view has type a rather than (a,()).+-- In order to do so, we can use 'RearrV', which first rearranges the view into the desired structure,+-- and then uses another BiGUL program to perform the transformation.+--+-- The usage of 'RearrV' is:+--+-- > RearrV (old-pattern) (new-pattern) (bigul-program)+--+-- 'PVar' means there is a variable (a hole to be update), and 'PVar'' is the same as 'PVar' except that it does not require the 'Eq' constraint.+-- In this concrete example, since the view is a single variable, the /old-pattern/ is 'PVar''.+-- 'DVar' still means there is a variable. But DVar should be used in the second argument of the 'RearrV'.+-- Since there may be many variables in the old-pattern, we need to mark the origin of each variable in the new-pattern: where does it come from.+-- In this concrete example, because there is only one variable in the old-pattern, a 'DVar' is enough to locate it.+-- Then we use 'EDir' to make 'DVar' becomes a direction, 'EProd' it with a constant 'EConst' ().+-- A more complex situation about the new-pattern is in the 'repFirstV3' example.++--+-- >>> put repFirstV2 (undefined , Nothing) 3+-- Right (3,Nothing)+--+-- >>> get repFirstV2 (True, undefined)+-- Right True+repFirstV2 :: (Show a, Show b) => BiGUL (a,b) a+repFirstV2 = RearrV PVar' (EDir DVar `EProd` EConst ()) repFirst++++-- |+-- > repFirstV2' = $(rearrV [| \v -> (v,()) |]) repFirst+-- It is difficult to use primitive combinators, especially when the problem becomes complex.+-- Here we introduce another syntactic sugar:+--+-- > $(rearrV [| \old-pattern -> new-pattern |]) bigul-program+-- When rearranging the view, it's possible to duplicate information:+--+-- > $(rearrV [| \v -> (v,v)|]) bigul-program+-- but it's __/not allowed/__ to drop information:+--+-- > $(rearrV [| \(vl,vr) -> vl |]) bigul-program           -- this is WRONG+repFirstV2' :: (Show a, Show b) => BiGUL (a,b) a+repFirstV2' = $(rearrV [| \v -> (v,()) |]) repFirst++++-- |+-- > repFirstV3 = RearrS (PVar' `PProd` PVar') (EDir (DLeft DVar)) Replace+-- The function produces exactly the same result as 'repFirstV2'.+-- The difference is that, instead of using 'RearrV' to rearrange the view into a tuple,+-- here we use 'RearrS' to rearrange the source into a single value of type a, and then simply use 'Replace' to update the source.+--+-- The usage of 'RearrS' is:+--+-- > RearrS (old-pattern) (new-pattern) (bigul-program)+-- The original source is a tuple, that is to say, there are two variables. So the old-pattern is (PVar' \`Prod\` PVar').+-- In the new-pattern, We need to tell BiGUL that, it is the first element of the tuple, i.e. the left element, we want to update.+-- This is achieved by (DLeft DVar). Finally, we convert it into a direction using 'EDir'.+repFirstV3 :: Show a => BiGUL (a,b) a+repFirstV3 = RearrS (PVar' `PProd` PVar') (EDir (DLeft DVar)) Replace+++-- |+-- > repFirstV3' = $(rearrS [| \(l, _) -> l |]) Replace+-- The syntactic sugar version for 'repFirstV3'.+-- The usage of the syntactic sugar is basically the same as $(rearrV ...):+--+-- > $(rearrS [| \old-pattern -> new-pattern |]) bigul-program+repFirstV3' :: Show a => BiGUL (a,b) a+repFirstV3' = $(rearrS [| \(l, _) -> l |]) Replace+++-- |+-- > repFirstV4 = Dep (const ()) ($(rearrS [| \(l, _) -> l |]) Replace)+-- Yet another version of 'repFirst'. This artificial example briefly introduces the constructor 'Dep', which is rather seldom used.+-- 'Dep' can be used to add or eliminate information on the view.+-- In this concrete example, since the second element of the view is a unit (()), it can be produced from any existing view v by+-- (const ()), which is equivalent to (\v -> const () v).+-- Now we can consider a bidirectional transformation f+--+-- > ($(rearrS [| \(l, _) -> l |]) Replace)+-- which is between source (a,b) and view a only.+-- Then both the transformation f and the function (const ()) are passed to 'Dep' to finally produce the transformation between (a, b) and (a, ())+repFirstV4 :: (Show a, Show b) => BiGUL (a, b) (a, ())+repFirstV4 = Dep (const ()) ($(rearrS [| \(l, _) -> l |]) Replace)++++-- |+-- >  Case  [ $(normal [| \(a,b) c -> a <= b && c <= b |]+-- >                   [|\(a,b) -> a <= b |])+-- >            $(update [p| (a,_) |] [p| a |] [d| a = Replace  |])+-- >        , $(normal [| \(a,b) c -> b < a  && c < a  |]+-- >                   [|\(a,b) -> b < a |])+-- >            $(update [p| (_,b) |] [p| b |] [d| b = Replace  |])+-- >        , $(normal [|\ _ _ -> True|]+-- >                   [|\(a,b) -> False |])+-- >            (Fail "the source view are not consistent.")+-- >        ]+-- Here we introduce the 'Case' combinator, which is extremely useful. 'Case' resembles the conditional branch in most languages.+-- In this concrete example, the 'Case' combinator enables us to do the following: Suppose the source is (a,b) and the view is c,+-- if (a <= b && c <= b), then we replace a with c; if (b < a && c < a), then we replace b with c; otherwise, the program fails.+-- Because in this case once the minimum element in the source is replaced, it is no longer the minimum element.+--+-- The general structure for 'Case' is:+--+-- > Case [ $(normal   [| enteringCond1  :: s -> v -> Bool |] [|exitCond1 :: s -> Bool |]) $+-- >          (bx1 :: BiGUL s v)+-- >      , $(adaptive [| enteringCond1' :: s -> v -> Bool |]) $+-- >          (f1 :: s -> v -> s)+-- >      , ...+-- >      , $(normal   [| enteringCondn  :: s -> v -> Bool |] [|exitCond1 :: s -> Bool |]) $+-- >         (bxn :: BiGUL s v)+-- >      , ...+-- >      , $(adaptive [| enteringCondm' :: s -> v -> Bool |]) $+-- >         (fm :: s -> v -> s)+-- >      ]+-- >     :: BiGUL s v+--+-- It contains a sequence of cases. For each case, it is either normal or adaptive. For+-- the normal case, if the condition is satisfied, a corresponding putback transformation+-- is applied. For the adaptive case, if the condition is satisfied, a function+-- is used to update the source with the view so that for the next step one of the+-- normal cases can be applied. Note that if adaptation does not lead the source+-- and the view to a normal case, an error will be reported at runtime.+-- The example for /adaptive/ branch is in the next example.+--+-- Note that $(normal ... ...) takes two predicates. The first one is the entering-condition while the second one is the exit-condition.+-- The predicate for entering-condition is very general, and we can use any function f of type (s -> v -> Bool) to examine the source and view.+-- If the condition is matched, then the BiGUL program after the predicate is executed. If the condition is not satisfied, the next branch is tried.+-- The predicate for exit-condition checks the source only. The exit-condition in different branches should be always NOT overlapped.+-- Eg: (a <= b), (b < a), (False) are not overlapped.+--+-- Note: instead of a general function, we can use patterns for predicate. The syntax is:+--+-- > $(normalSV [p| source-pattern |] [p| view-pattern |] [| exitCond |] )+-- > ...+-- > $(adaptiveSV [p| source-pattern |] [p| view-pattern |])+-- For example:+--+-- > $(normalSV [p| Left _:_ |] [p| [] |]+-- >            [| exitCond |] )+-- states that the source is a non-empty list with the first element in a /Left/ constructor,+-- and the view is an empty list. This feature is heavily used in the 'naiveMap' example.+--+-- Please avoid using variables in the pattern-predicate: always use an underline.+--+-- >>> put replaceMin (2,7) 4+-- Right (4,7)+--+-- >>> put replaceMin (2,7) 10+-- Left fail: the source view are not consistent.+--+-- >>> get replaceMin (2,7)+-- Right 2+replaceMin :: BiGUL (Int, Int) Int+replaceMin =+  Case  [ $(normal [| \(a,b) c -> a <= b && c <= b |]+                   [|\(a,b) -> a <= b |])+            $(update [p| (a,_) |] [p| a |] [d| a = Replace  |])+        , $(normal [| \(a,b) c -> b < a  && c < a  |]+                   [|\(a,b) -> b < a |])+            $(update [p| (_,b) |] [p| b |] [d| b = Replace  |])+        , $(normal [|\ _ _ -> True|]+                   [|\(a,b) -> False |])+            (Fail "the source view are not consistent.")+        ]++++-- |+-- > lensLength def =+-- >   Case [ $(adaptive [| \s v -> length s /= v |])+-- >            (\s v -> let ls = length s+-- >                     in  if ls > v then drop (ls - v) s+-- >                                   else replicate (v - ls) def ++ s)+-- >        , $(normal [|\s v -> length s == v |]+-- >                   [| const True |])+-- >            (Skip length)+-- >        ]+-- In this example, the source is any list and the view is the length of the source.+-- Note that The function is not a lens: we should provide the function with a default value to make it a lens.+-- The default value is used to generate new elements and thus expand the source, when the view is greater than the length of the source.+-- If the view is less than the length of the source, the source will be shortened.+--+-- Here we introduce the adaptive branch of 'Case', which takes a predicate (just like 'Normal' branch),+-- and a function (f :: s -> v -> s) that is used to create a new source.+-- Adaptive branch can be placed anywhere in a 'Case'.+-- Once the adaptive branch is executed and the new source is created, the whole 'Case' will be re-executed from the first branch.+-- If again an adaptive branch is matched, an error is thrown.+--+-- Another point is that, adaptive branch is chosen in the put direction only. In the get direction, it will never be chosen.+--+-- >>> put (lensLength 10) [2,2,1] 2+-- Right [2,1]+--+-- >>> put (lensLength 10) [2,2,1] 6+-- Right [10,10,10,2,2,1]+--+-- >>> get (lensLength undefined) [1..10]+-- Right 10+lensLength :: a -> BiGUL [a] Int+lensLength def =+  Case [ $(adaptive [| \s v -> length s /= v |])+           (\s v -> let ls = length s+                    in  if ls > v then drop (ls - v) s+                                  else replicate (v - ls) def ++ s)+       , $(normal [|\s v -> length s == v |]+                  [| const True |])+           (Skip length)+       ]+++-- |+-- > lensLength' def = emb length p+-- >   where p = \s v -> let ls = length s+-- >                     in  if ls > v then drop (ls - v) s+-- >                                   else replicate (v - ls) def ++ s+-- In fact what lensLength expresses is just that: We have two functions g and p,+-- g is used to do the get (by a 'Normal' branch), while p is used to do the put (by an 'Adaptive' branch).+-- this intention can be expressed in a more simple and modular way: using the 'emb' (embed) function.+-- the definition of 'emb' can be found in the next example.+lensLength' :: a -> BiGUL [a] Int+lensLength' def = emb length p+  where p = \s v -> let ls = length s+                    in  if ls > v then drop (ls - v) s+                                  else replicate (v - ls) def ++ s+++-- |+-- > (==>) = ($)+-- make it more elegant to write ($). Later we may use (==>) instead of ($).+(==>) :: (a -> b) -> a -> b+(==>) = ($)++-- |+-- > emb g p = Case+-- >   [ $(normal [| \s v -> g s == v |] [p| _ |])+-- >     ==> Skip g+-- >   , $(adaptive [| \s v -> True |])+-- >     ==> p+-- >   ]+-- emb g p: invoke g to do the get, and invoke p to do the put.+emb :: Eq v => (s -> v) -> (s -> v -> s) -> BiGUL s v+emb g p = Case+  [ $(normal [| \s v -> g s == v |] [p| _ |])+    ==> Skip g+  , $(adaptive [| \s v -> True |])+    ==> p+  ]+++-- |+-- > lensSucc = emb (flip (+) 1) (\_ v -> v - 1)+-- Sometimes 'emb' is useful. For instance, Int is a primitive datatype without any constructor in Haskell,+-- and cannot be manipulated in a way like list in 'ReaarV' or 'RearrS'.+-- For list, we can write (x:xs) -> (x:x:xs) using its constructor. But we cannot decompose Int.+-- Making use of 'emb', we can manipulate basic operations for Int, whose well-behavedness should be proved by hand.+-- (But here, the well-behavedness is easily seen.)+--+-- >>> put lensSucc 0 10+-- Right 9+--+-- >>> get lensSucc 8+-- Right 9+lensSucc :: BiGUL Int Int+lensSucc = emb (flip (+) 1) (\_ v -> v - 1)++-- |+-- > naiveMap b =+-- >   Case  [ $(normalSV [p| _:_ |] [p| _:_ |]+-- >                      [p| _:_ |])+-- >           ==> $(update [p| x:xs |] [p| x:xs |] [d| x = b; xs = naiveMap b |])+-- >         , $(adaptiveSV [p| _:_ |] [p| [] |] ) (\_ _ -> [])+-- >         , $(normalSV [p| [] |] [p| _:_ |]+-- >                      [| const False |])+-- >           ==> (Fail "length of the view should be less than that of the source.")+-- >         , $(normalSV [p| [] |] [p| [] |]+-- >                      [p| [] |])+-- >           ==> $(update [p| [] |] [p| [] |] [d| |])+-- >         ]+-- A naive map function, which takes a BiGUL program and yields another BiGUL program working on list.+-- The first branch deals with recursive condition.+-- The second branch handles the boundary conditions where the source list is longer than the view list:+-- drop all the remaining elements in the source list and thus make it an empty list.+-- The third branch will throw an error when the view list is longer than the source list.+-- The last branch is the termination condition: both the source and view reach the empty constructor.+--+-- (For the sake of completeness.) In fact 'normalSV' means that we use separate condition for source and view.+-- So we can still use a general function in the predicate:+--+-- > $(normalSV [| \s -> case s of _:_ -> True; _ -> False |] [p| _:_  |] [p| _:_ |])+--+-- >>> put (naiveMap lensSucc) [1,2,3,4] [7,8,9]+-- Right [6,7,8]+--+-- >>> get (naiveMap (lensLength undefined)) ["123", "xyz"]+-- Right [3,3]+--+-- >>>get (naiveMap replaceMin) [(3,9), (-2,10),(10,2)]+-- Right [3,-2,2]++naiveMap :: (Show a, Show b) => BiGUL a b -> BiGUL [a] [b]+naiveMap b =+  Case  [ $(normalSV [p| _:_ |] [p| _:_ |]+                     [p| _:_ |])+          ==> $(update [p| x:xs |] [p| x:xs |] [d| x = b; xs = naiveMap b |])+        , $(adaptiveSV [p| _:_ |] [p| [] |] ) (\_ _ -> [])+        , $(normalSV [p| [] |] [p| _:_ |]+                     [| const False |])+          ==> (Fail "length of the view should be less than that of the source.")+        , $(normalSV [p| [] |] [p| [] |]+                     [p| [] |])+          ==> $(update [p| [] |] [p| [] |] [d| |])+        ]++-- |+-- > compose = Compose+-- The last combinator we are going to introduce is 'Compose',+-- which takes two BiGUL programs and behaves like \"function composition\".+--+-- Given two BiGUL programs,+--+-- > f :: BiGUL a b, g :: BiGUL b c+-- we have+--+-- > f `Compose` g :: BiGUL a c+-- In the get direction, the semantics of @get (f \`Compose\` g) s@ is:+-- (suppose the function 'get' and 'put' always return a value rather than a value wrapped in 'Right'.)+--+-- > get g (get f s)+-- In the put direction, the semantics of @put (f \`Compose\` g) s v@ is a little bit complex:+--+-- > put f s (put g (get f s) v)+-- Let us make it more clear:+--+-- > let a = get f s+-- >     b = put g a v+-- > in  put f s b+-- Check the type of these transformations by yourself will help you understand deeper.+--+-- Let us try some examples:+--+-- >>> put ((naiveMap replaceMin) `compose` (naiveMap lensSucc)) [(1,-1),(-2,2)] [-8, 1]+-- Right [(1,-9),(0,2)]+--+-- >>> get ((naiveMap replaceMin) `compose` (naiveMap lensSucc)) [(1,-1),(-2,2)]+-- Right [0,-1]+compose :: (Show a, Show b, Show c) => BiGUL a b -> BiGUL b c -> BiGUL a c+compose = Compose++-- |+-- The last example in this tutorial is a simple map-map fusion.+-- It makes the composition of two map functions run more efficiently, compared to using 'Compose' combinator.+--+-- In the get direction, (get (f \`Compose\` g)) traverse the list twice, while (get (mapFusion f g)) traverse the list only once.+-- And in the put direction, (put f \`Compose\` g) traverse the two lists up to five times (get counts up once, two put count up four times, since a put takes two lists as argument),+-- while (put mapFusion f g) traverses the lists only twice.+--+-- Compare the following result (in GHCI)+--+-- > t1 :: Int+-- > t1 = last $ fromRight $ put (naiveMap lensSucc `Compose` naiveMap lensSucc) [1..100000] [2..20001]+-- > t2 :: Int+-- > t2 = last $ fromRight $ put (mapFusion lensSucc lensSucc) [1..100000] [2..20001]+-- > fromRight (Right x) = x+--+-- >>> t1+-- 19999+-- (1.24 secs, 512,471,456 bytes)+--+-- >>> t2+-- 19999+-- (0.23 secs, 122,920,792 bytes)+--+-- More examples can be found in the list library of BiGUL.+mapFusion :: (Show a, Show b, Show c) => BiGUL a b -> BiGUL b c -> BiGUL [a] [c]+mapFusion f g =+  Case  [ $(normalSV [p| _:_ |] [p| _:_ |]+                     [p| _:_ |])+          ==> $(update [p| x:xs |] [p| x:xs |] [d| x = f `Compose` g; xs = mapFusion f g |])+        , $(adaptiveSV [p| _:_ |] [p| [] |] ) (\_ _ -> [])+        , $(normalSV [p| [] |] [p| _:_ |]+                     [| const False |])+          ==> (Fail "length of the view should be less than that of the source")+        , $(normalSV [p| [] |] [p| [] |]+                     [p| [] |])+          ==> $(update [p| [] |] [p| [] |] [d| |])+        ]
+ src/Generics/BiGUL/Lib/List.hs view
@@ -0,0 +1,51 @@+-- | A library for processing lists in BiGUL.++module Generics.BiGUL.Lib.List where++import Generics.BiGUL+import Generics.BiGUL.TH+import Generics.BiGUL.Lib++import Control.Arrow ((***))+import Data.Maybe (isJust, catMaybes)+++-- | List alignment. Operating only on the sources satisfying the source condition,+--   and using the specified matching condition, 'align' finds for each view the first matching source+--   that has not been matched with previous views, and updates the source using the inner program.+--   If there is no matching source, one is created using the creation argument —+--   after creation, the created source should match with the view as determined by the matching condition.+--   For a source not matched with any view, the concealment argument is applied —+--   if concealment computes to @Nothing@, the source is deleted;+--   if concealment computes to @Just s'@, where @s'@ should not satisfy the source condition,+--   the source is replaced by @s'@.+align :: (Show a, Show b)+      => (a -> Bool)       -- ^ source condition+      -> (a -> b -> Bool)  -- ^ matching condition+      -> BiGUL a b         -- ^ inner program+      -> (b -> a)          -- ^ creation+      -> (a -> Maybe a)    -- ^ concealment+      -> BiGUL [a] [b]+align p match b create conceal = Case+  [ $(normalSV [| null . filter p |] [p| [] |] [| null . filter p |])+    ==> $(rearrV [| \[] -> () |])$+          skip ()+  , $(adaptiveSV [p| _ |] [p| [] |])+    ==> \ss _ -> catMaybes (map (\s -> if p s then conceal s else Just s) ss)+  -- view is necessarily nonempty in the cases below+  , $(normalSV [p| (p -> False):_ |] [p| _ |] [p| (p -> False):(null . filter p -> False) |])+    ==> $(rearrS [| \(s:ss) -> ss |])$+          align p match b create conceal+  , $(normal [| \(s:ss) (v:vs) -> p s && match s v |] [p| (p -> True):_ |])+    ==> $(update [p| x:xs |] [p| x:xs |] [d| x = b; xs = align p match b create conceal |])+  , $(adaptive [| \ss (v:_) -> isJust (findFirst (\s -> p s && match s v) ss) ||+                               let s = create v in p s && match s v |])+    ==> \ss (v:_) -> maybe (create v:ss) (uncurry (:)) (findFirst (\s -> p s && match s v) ss)+  ]+  where+    findFirst :: (a -> Bool) -> [a] -> Maybe (a, [a])+    findFirst p [] = Nothing+    findFirst p (x:xs) | p x       = Just (x, xs)+    findFirst p (x:xs) | otherwise = fmap (id *** (x:)) (findFirst p xs)++
+ src/Generics/BiGUL/PatternMatching.hs view
@@ -0,0 +1,104 @@+-- | This module implements the rearrangement operations, which are based on pattern matching.++module Generics.BiGUL.PatternMatching where++import Generics.BiGUL+import Generics.BiGUL.Error++import GHC.InOut++import Control.Monad.Except+++modifyError :: (e -> e) -> Either e a -> Either e a+modifyError f = either (Left . f) Right++deconstruct :: Pat a env con -> a -> Either PatError env+deconstruct PVar          x         = return (Var x)+deconstruct PVar'         x         = return (Var x)+deconstruct (PConst c)    x         = if c == x then return () else throwError PEConstantMismatch+deconstruct (l `PProd` r) (x, y)    = liftM2 (,) (modifyError PEProdL (deconstruct l x))+                                                 (modifyError PEProdR (deconstruct r y))+deconstruct (PLeft  p)    (Left  x) = modifyError PELeft  (deconstruct p x)+deconstruct (PLeft  _)    _         = throwError PELeftMismatch+deconstruct (PRight p)    (Right x) = modifyError PERight (deconstruct p x)+deconstruct (PRight _)    _         = throwError PERightMismatch+deconstruct (PIn p)       x         = modifyError PEIn    (deconstruct p (out x))++construct :: Pat a env con -> env -> a+construct PVar          (Var x) = x+construct PVar'         (Var x) = x+construct (PConst c)    _       = c+construct (l `PProd` r) (x, y)  = (construct l x, construct r y)+construct (PLeft  p)    x       = Left  (construct p x)+construct (PRight p)    x       = Right (construct p x)+construct (PIn p)       x       = inn (construct p x)++retrieve :: Direction env a -> env -> a+retrieve  DVar      (Var x ) = x+retrieve (DLeft  d) (env, _) = retrieve d env+retrieve (DRight d) (_, env) = retrieve d env++eval :: Expr env a -> env -> a+eval (EDir d)      env = retrieve d env+eval (EConst c)    env = c+eval (l `EProd` r) env = (eval l env, eval r env)+eval (ELeft  e)    env = Left  (eval e env)+eval (ERight e)    env = Right (eval e env)+eval (EIn e)       env = inn (eval e env)++uneval :: Pat a env con -> Expr env b -> b -> con -> Either PatError con+uneval p (EDir d)     x         con = unevalDir p d x con+uneval p (EConst c)   x         con = if c == x then return con else throwError PEConstantMismatch+uneval p (EProd l r)  (x, y)    con = modifyError PEProdL (uneval p l x con) >>= modifyError PEProdR . uneval p r y+uneval p (ELeft  e)   (Left  x) con = modifyError PELeft  (uneval p e x con)+uneval p (ELeft  _)   x         con = throwError PELeftMismatch+uneval p (ERight e)   (Right x) con = modifyError PERight (uneval p e x con)+uneval p (ERight _)   x         con = throwError PERightMismatch+uneval p (EIn e)      x         con = modifyError PEIn    (uneval p e (out x) con)++unevalDir :: Pat a env con -> Direction env b -> b -> con -> Either PatError con+unevalDir PVar          DVar       x (Just y)     = if x == y+                                                    then return (Just x)+                                                    else throwError PEIncompatibleUpdates+unevalDir PVar          DVar       x Nothing      = return (Just x)+unevalDir PVar'         DVar       x (Just y)     = throwError PEMultipleUpdates+unevalDir PVar'         DVar       x Nothing      = return (Just x)+unevalDir (PConst c)    _          x con          = return con+unevalDir (l `PProd` r) (DLeft  d) x (conl, conr) = liftM (, conr) (modifyError PEProdL (unevalDir l d x conl))+unevalDir (l `PProd` r) (DRight d) x (conl, conr) = liftM (conl ,) (modifyError PEProdR (unevalDir r d x conr))+unevalDir (PLeft  p)    d          x con          = modifyError PELeft  (unevalDir p d x con)+unevalDir (PRight p)    d          x con          = modifyError PERight (unevalDir p d x con)+unevalDir (PIn p)       d          x con          = modifyError PEIn    (unevalDir p d x con)++fromContainerV :: Pat v env con -> con -> Either PatError env+fromContainerV PVar          Nothing      = throwError PEValueUnrecoverable+fromContainerV PVar          (Just v)     = return (Var v)+fromContainerV PVar'         Nothing      = throwError PEValueUnrecoverable+fromContainerV PVar'         (Just v)     = return (Var v)+fromContainerV (PConst c)    con          = return ()+fromContainerV (l `PProd` r) (conl, conr) = liftM2 (,) (modifyError PEProdL (fromContainerV l conl))+                                                       (modifyError PEProdR (fromContainerV r conr))+fromContainerV (PLeft  p)    con          = modifyError PELeft  (fromContainerV p con)+fromContainerV (PRight p)    con          = modifyError PERight (fromContainerV p con)+fromContainerV (PIn p)       con          = modifyError PEIn    (fromContainerV p con)++fromContainerS :: Pat s env con -> env -> con -> env+fromContainerS PVar          (Var s)      Nothing      = (Var s )+fromContainerS PVar          (Var s)      (Just s')    = (Var s')+fromContainerS PVar'         (Var s)      Nothing      = (Var s )+fromContainerS PVar'         (Var s)      (Just s')    = (Var s')+fromContainerS (PConst c)    _            _            = ()+fromContainerS (l `PProd` r) (envl, envr) (conl, conr) = (fromContainerS l envl conl, fromContainerS r envr conr)+fromContainerS (PLeft  p)    env          con          = fromContainerS p env con+fromContainerS (PRight p)    env          con          = fromContainerS p env con+fromContainerS (PIn p)       env          con          = fromContainerS p env con++emptyContainer :: Pat v env con -> con+emptyContainer PVar          = Nothing+emptyContainer PVar'         = Nothing+emptyContainer (PConst c)    = ()+emptyContainer (l `PProd` r) = (emptyContainer l, emptyContainer r)+emptyContainer (PLeft  p)    = emptyContainer p+emptyContainer (PRight p)    = emptyContainer p+emptyContainer (PIn p)       = emptyContainer p
src/Generics/BiGUL/TH.hs view
@@ -1,5 +1,48 @@-module Generics.BiGUL.TH( normal, normal', normalS, normalV, normalV', normalSV, adaptive, adaptiveS, adaptiveV, adaptiveSV, update, deriveBiGULGeneric, rearrS, rearrV) where+-- | A higher-level syntax for programming in BiGUL, implemented in Template Haskell. +module Generics.BiGUL.TH (+  -- * 'GHC.Generics.Generic' instance derivation+    deriveBiGULGeneric+  -- * Rearrangement+  -- | * BiGUL does not support pattern matching for /n/-tuples where /n/ >= 3.+  --         For convenience (but possibly confusingly),+  --         the programmer __can__ use /n/-tuple patterns with the Template Haskell rearrangement syntax,+  --         but these patterns are translated into ones for right-nested pairs.+  --         For example, a 3-tuple pattern @(x, y, z)@ used in a rearrangement is in fact translated into @(x, (y, z))@.+  --+  --   * In a rearranging lambda-expression, if a pattern variable is used more than once in the body,+  --         the type of the pattern variable will be required to be an instance of 'Eq'.+  --+  --   * If an error message+  --+  --         > ‘C’ is not in the type environment at a reify+  --+  --         is reported where @C@ is a constructor used in a rearrangement,+  --         perhaps you forget to invoke 'deriveBiGULGeneric' on @C@’s datatype.+  , rearrS+  , rearrV+  , update+  -- * 'Case' branch construction+  -- | * In the following branch construction syntax, the meaning of a boolean-valued pattern-matching lambda-expression+  --         is redefined as a __total__ function which computes to 'False' when an input does not match the pattern;+  --         this meaning is different from that of a general pattern-matching lambda-expression, which fails to compute+  --         when the pattern is not matched. For example, in general the lambda-expression+  --+  --         > \(s:ss) (v:vs) -> s == v+  --+  --         will fail to compute if one of its inputs is an empty list; when used in branch construction, however,+  --         the lambda-expression will compute to 'False' upon encountering an empty list.+  --+  --   * An argument whose type is an instance of 'ExpOrPat' (a typeclass not exported) can be either+  --         a quoted expression (of type 'Language.Haskell.TH.Q' 'Language.Haskell.TH.Exp'),+  --         which should describe a unary or binary predicate (boolean-valued function), or a quoted pattern+  --         (of type 'Language.Haskell.TH.Q' 'Language.Haskell.TH.Pat'), which is translated into+  --         a unary predicate that computes to 'True' if the pattern is matched, or 'False' otherwise.+  , normal+  , normalSV+  , adaptive+  , adaptiveSV) where+ import Data.Data import Data.Maybe import Data.List as List@@ -8,16 +51,19 @@ import Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as THS import Language.Haskell.TH.Quote-import Generics.BiGUL.AST+import Language.Haskell.TH.Extras (nameOfCon, namesBoundInPat)+import Generics.BiGUL import Control.Monad  -data ConTag = L | R-    deriving (Show, Data, Typeable)+astNamespace :: String+astNamespace = "Generics.BiGUL" +data ConTag = L | R+  deriving (Show, Data, Typeable)  data PatTag = RTag   -- ^ view pattern-            | STag   -- ^ source Pattern+            | STag   -- ^ source pattern             | ETag   -- ^ expression  instance Show PatTag where@@ -25,29 +71,33 @@    show _    = "P"  contag :: a -> a -> ConTag -> a-contag a1 _  L = a1-contag _  a2 R = a2---class ConTagSeq a where-  toConTags :: a -> Name -> [ConTag]-+contag x _ L = x+contag _ y R = y -type TypeConstructor = String+type Namespace        = String+type TypeConstructor  = String type ValueConstructor = String-type ErrorMessage = String-+type ErrorMessage     = String  lookupName :: (String -> Q (Maybe Name)) -> ErrorMessage -> String -> Q Name lookupName f errMsg name = f name >>= maybe (fail errMsg) return --- ["Generic", "K1", "U1", ":+:", ":*:", "Rep"]-lookupNames :: [TypeConstructor] -> [ValueConstructor] -> ErrorMessage -> Q ([Name], [Name])-lookupNames typeCList valueCList errMsg = liftM2 (,) (mapM (lookupName lookupTypeName  errMsg) typeCList)-                                                     (mapM (lookupName lookupValueName errMsg) valueCList)+lookupNames :: Namespace -> [TypeConstructor] -> [ValueConstructor] -> Q ([Name], [Name])+lookupNames namespace typeCList valueCList =+  let qualifiedName c = namespace ++ "." ++ c+      errorMessage  c = "‘" ++ c ++ "’ is not in scope (perhaps you forget to import " ++ namespace ++ ")"+  in  liftM2 (,) (mapM (\c -> lookupName lookupTypeName  (errorMessage c) (qualifiedName c)) typeCList )+                 (mapM (\c -> lookupName lookupValueName (errorMessage c) (qualifiedName c)) valueCList) --- Find the Type Dec by Name--- Construct an InstanceDec.+-- | Generate a 'GHC.Generics.Generic' instance for a named datatype+--   so that its constructors can be used in rearranging lambda-expressions.+--   Invoke this function on a datatype @T@ by putting+--+--   > deriveBiGULGeneric ''T+--+--   at the top level of a source file (say, after the definition of @T@).+--   Only simple datatypes and newtypes are supported (no GADTs, for example);+--   type parameters and named fields (record syntax) are supported. deriveBiGULGeneric :: Name -> Q [InstanceDec] deriveBiGULGeneric name = do   (name, typeVars, constructors) <-@@ -55,111 +105,105 @@       info <- reify name       case info of         (TyConI (DataD [] name typeVars constructors _)) -> return (name, typeVars, constructors)-        _            -> fail ( "cannot find " ++ nameBase name ++ ", 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]) <--    lookupNames [ "GHC.Generics." ++ s | s <- ["Generic", "Rep", "K1", "R", "U1", ":+:", ":*:", "V1", "S1", "Selector", "Datatype"] ]-                [ "GHC.Generics." ++ s | s <- ["from", "to", "K1", "L1", "R1", "U1", ":*:", "selName", "datatypeName", "moduleName", "M1"] ]-                "cannot find type/value constructors from GHC.Generics."+        (TyConI (NewtypeD [] name typeVars constructor _)) -> 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]) <-+    lookupNames "GHC.Generics"+                ["Generic", "Rep", "K1", "R", "U1", ":+:", ":*:", "V1", "S1", "Selector", "Datatype"]+                ["from", "to", "K1", "L1", "R1", "U1", ":*:", "selName", "datatypeName", "moduleName", "M1"]   env <- consToEnv constructors-  let selectorsNameList =  generateSelectorNames constructors+  selectorsNameList <- generateSelectorNames constructors   let selectorDataDMaybeList = generateSelectorDataD selectorsNameList-  let selectorDataTypeMaybeList = map (generateSelectorDataType nDataType vDataTypeName vModuleName (maybe "" id (nameModule name))) selectorsNameList+  let selectorDataTypeMaybeList =+        map (generateSelectorDataType nDataType vDataTypeName vModuleName (maybe "" id (nameModule name)))+            selectorsNameList   let selectorNameAndConList = zip selectorsNameList constructors   let selectorInstanceDecList = map (generateSelectorInstanceDec nSelector vSelName) selectorNameAndConList   let fromClauses = map (constructFuncFromClause (vK1, vU1, vL1, vR1, vProd, vM1)) env   let toClauses   = map (constructFuncToClause (vK1, vU1, vL1, vR1, vProd, vM1)) env-  --conTagsClause <- toconTagsClause env-  return $ listMaybe2Just selectorDataDMaybeList ++-           listMaybe2Just (concat selectorDataTypeMaybeList) ++-           listMaybe2Just (concat selectorInstanceDecList) +++  return $ catMaybes selectorDataDMaybeList +++           catMaybes (concat selectorDataTypeMaybeList) +++           catMaybes (concat selectorInstanceDecList) ++            [InstanceD []-                     (AppT (ConT nGeneric) (generateTypeVarsType name typeVars))-                     [TySynInstD nRep-                                 (TySynEqn-                                    [generateTypeVarsType name typeVars]-                                    (constructorsToSum (nSum, nV1) (map (constructorToProduct (nK1, nR, nU1, nProd, nS1)) selectorNameAndConList))),-                      FunD vFrom fromClauses,-                      FunD vTo toClauses ]+              (AppT (ConT nGeneric) (generateTypeVarsType name typeVars))+              [TySynInstD nRep+                 (TySynEqn+                    [generateTypeVarsType name typeVars]+                    (constructorsToSum (nSum, nV1)+                       (map (constructorToProduct (nK1, nR, nU1, nProd, nS1)) selectorNameAndConList))),+               FunD vFrom fromClauses,+               FunD vTo toClauses]             ] -listMaybe2Just :: [Maybe a] -> [a]-listMaybe2Just xs = foldr (\a b -> case a of {Just v -> v:b; Nothing -> b}) [] xs---toconTagsClause :: [(Bool, Name, [ConTag], [Name])] -> Q Clause-toconTagsClause env = do-  (_, [vEq, vError]) <- lookupNames [] ["==", "error"] "cannot find functions for eq or error."-  conTagsVarName <- newName "name"-  expEnv <- mapM (\(b, n, conTags, _) -> liftM2 (,) (dataToExpQ (const Nothing) n) (dataToExpQ (const Nothing) conTags)) env-  let conTagsClauseBody = (foldr (\(nExp, lrsExp) e -> CondE ((VarE vEq `AppE` nExp) `AppE` VarE conTagsVarName) lrsExp e)-                (VarE vError `AppE` LitE (StringL "cannot find name."))-                expEnv)-  return $ Clause [WildP, VarP conTagsVarName] (NormalB conTagsClauseBody) []--- constructorsToSum :: (Name, Name) -> [Type] -> Type-constructorsToSum (sum, v1) []  = ConT v1 -- empty+constructorsToSum (sum, v1) []  = ConT v1 constructorsToSum (sum, v1) tps = foldr1 (\t1 t2 -> (ConT sum `AppT` t1) `AppT` t2) tps - constructorToProduct :: (Name, Name, Name, Name, Name) -> ([Maybe Name], Con) -> Type constructorToProduct (k1, r, u1, prod, s1) (_,     NormalC _ [] ) = ConT u1-constructorToProduct (k1, r, u1, prod, s1) (_,     NormalC _ sts) = foldr1 (\t1 t2 -> (ConT prod `AppT` t1 ) `AppT` t2) $ map (AppT (ConT k1 `AppT` ConT r) . snd) sts-constructorToProduct (k1, r, u1, prod, s1) (names, RecC    _ sts) = foldr1 (\t1 t2 -> (ConT prod `AppT` t1 ) `AppT` t2) $ map (\(Just n, st) -> AppT (ConT s1 `AppT` ConT n) ((ConT k1 `AppT` ConT r) `AppT` third st)) (zip names sts)-constructorToProduct _ _ = error "not supported Con"--third :: (a, b, c) -> c-third  (_, _, z) = z+constructorToProduct (k1, r, u1, prod, s1) (_,     NormalC _ sts) =+  foldr1 (\t1 t2 -> (ConT prod `AppT` t1 ) `AppT` t2) (map (AppT (ConT k1 `AppT` ConT r) . snd) sts)+constructorToProduct (k1, r, u1, prod, s1) (names, RecC    _ sts) =+  foldr1 (\t1 t2 -> (ConT prod `AppT` t1 ) `AppT` t2)+    (map (\(Just n, (_,_,t)) -> AppT (ConT s1 `AppT` ConT n) ((ConT k1 `AppT` ConT r) `AppT` t)) (zip names sts))+constructorToProduct _                     (_,     c)             =+  error ("Constructor ‘" ++ nameBase (nameOfCon c) ++ "’ is of an unsupported kind")  -- Bool indicates: if Normal then False else RecC True constructorToPatAndBody :: Con -> Q (Bool, Name, [Name])-constructorToPatAndBody (NormalC name sts) = liftM (False, name,) $ replicateM (length sts) (newName "var")-constructorToPatAndBody (RecC    name sts) = liftM (True, name,) $ replicateM (length sts) (newName "var")-constructorToPatAndBody _ = fail "not supported Cons"-+constructorToPatAndBody (NormalC name sts) = liftM (False, name,) (replicateM (length sts) (newName "var"))+constructorToPatAndBody (RecC    name sts) = liftM (True , name,) (replicateM (length sts) (newName "var"))+constructorToPatAndBody c                  =+  fail ("Constructor ‘" ++ nameBase (nameOfCon c) ++ "’ is of an unsupported kind")  zipWithLRs :: [(Bool, Name, [Name])] ->  [(Bool, Name, [ConTag], [Name])] zipWithLRs nns = zipWith (\(b, n, ns) lrs -> (b, n, lrs, ns)) nns (constructLRs (length nns))  consToEnv :: [Con] -> Q [(Bool, Name, [ConTag], [Name])]-consToEnv cons = liftM zipWithLRs $ mapM constructorToPatAndBody cons+consToEnv cons = liftM zipWithLRs (mapM constructorToPatAndBody cons)  constructFuncFromClause :: (Name, Name, Name, Name, Name, Name) -> (Bool, Name, [ConTag], [Name]) -> Clause-constructFuncFromClause (vK1, vU1, vL1, vR1, vProd, vM1) (b, n, lrs, names) =  Clause [ConP n (map VarP names)] (NormalB (wrapLRs lrs (deriveGeneric names))) []+constructFuncFromClause (vK1, vU1, vL1, vR1, vProd, vM1) (b, n, lrs, names) =+  Clause [ConP n (map VarP names)] (NormalB (wrapLRs lrs (deriveGeneric names))) []   where     wrapLRs :: [ConTag] -> Exp -> Exp     wrapLRs lrs exp = foldr (\lr e -> ConE (contag vL1 vR1 lr) `AppE` e) exp lrs      deriveGeneric :: [Name] -> Exp     deriveGeneric []    = ConE vU1-    deriveGeneric names = foldr1 (\e1 e2 -> (ConE vProd `AppE` e1) `AppE` e2) $ map (\name -> if b then ConE vM1 `AppE` (ConE vK1 `AppE` VarE name) else ConE vK1 `AppE` VarE name) names-+    deriveGeneric names = foldr1 (\e1 e2 -> (ConE vProd `AppE` e1) `AppE` e2)+                            (map (\name -> if b then ConE vM1 `AppE` (ConE vK1 `AppE` VarE name)+                                                else ConE vK1 `AppE` VarE name) names)  constructFuncToClause :: (Name, Name, Name, Name, Name, Name) -> (Bool, Name, [ConTag], [Name])  -> Clause-constructFuncToClause (vK1, vU1, vL1, vR1, vProd, vM1) (b, n, lrs, names)  = Clause [wrapLRs lrs (deriveGeneric names)] (NormalB (foldl (\e1 name -> e1 `AppE` (VarE name)) (ConE n) names) ) []+constructFuncToClause (vK1, vU1, vL1, vR1, vProd, vM1) (b, n, lrs, names) =+  Clause [wrapLRs lrs (deriveGeneric names)] (NormalB (foldl (\e1 name -> e1 `AppE` (VarE name)) (ConE n) names) ) []   where     wrapLRs :: [ConTag] -> TH.Pat -> TH.Pat     wrapLRs lrs pat = foldr (\lr p -> ConP (contag vL1 vR1 lr) [p]) pat lrs      deriveGeneric :: [Name] -> TH.Pat     deriveGeneric []    = ConP vU1 []-    deriveGeneric names = foldr1 (\p1 p2 -> ConP vProd [p1, p2]) $ map (\name -> if b then (ConP vM1 ((:[]) (ConP vK1 ((:[]) (VarP name))))) else (ConP vK1 ((:[]) (VarP name)))) names+    deriveGeneric names = foldr1 (\p1 p2 -> ConP vProd [p1, p2])+                            (map (\name -> if b then (ConP vM1 ((:[]) (ConP vK1 ((:[]) (VarP name)))))+                                                else (ConP vK1 ((:[]) (VarP name)))) names)  -- construct selector names from constructors-generateSelectorNames :: [Con] -> [[Maybe Name]]-generateSelectorNames = map (\con ->+generateSelectorNames :: [Con] -> Q [[Maybe Name]]+generateSelectorNames = mapM (\con ->   case con of {-      RecC _ sts -> map (\(n, _, _) -> Just (mkName ( "Selector_" ++ nameBase n))) sts;-      _          -> []+      RecC _ sts -> mapM (\(n, _, _) -> newName ("Selector_" ++ nameBase n) >>= return . Just) sts;+      _          -> return []     })  generateSelectorDataD :: [[Maybe Name]] -> [Maybe Dec]-generateSelectorDataD names = map (\name -> case name of {Just n -> Just $ DataD [] n [] [] []; Nothing -> Nothing}) (concat names)+generateSelectorDataD names = map (fmap (\n -> DataD [] n [] [] [])) (concat names)  -- Selector DataType Generation generateSelectorDataType :: Name -> Name -> Name -> String -> [Maybe Name] -> [Maybe Dec]-generateSelectorDataType nDataType vDataTypeName vModuleName moduleName = map (generateSelectorDataType' nDataType vDataTypeName vModuleName moduleName)+generateSelectorDataType nDataType vDataTypeName vModuleName moduleName =+  map (generateSelectorDataType' nDataType vDataTypeName vModuleName moduleName)  generateSelectorDataType' :: Name -> Name -> Name -> String -> Maybe Name -> Maybe Dec generateSelectorDataType' nDataType vDataTypeName vModuleName moduleName (Just selectorName) =@@ -182,7 +226,6 @@             [FunD vSelName ([Clause [WildP] (NormalB (LitE (StringL (nameBase name)))) []])] generateSelectorInstanceDec' _         _         _                          = Nothing - -- generate type representation of polymorhpic type -- e.g. VBook a b is represented as: AppT (ConT name) (ConT name_a `AppT` ConT name_b) generateTypeVarsType :: Name -> [TyVarBndr] -> Type@@ -190,10 +233,9 @@ generateTypeVarsType n tvars = foldl (\a b -> AppT a b) (ConT n) $ map (\tvar ->    case tvar of     { PlainTV  name      -> VarT name;-      KindedTV name kind -> VarT name-- error "kind type variables are not supported yet."+      KindedTV name kind -> VarT name -- error "kind type variables are not supported yet."     }) tvars - constructLRs :: Int -> [[ConTag]] constructLRs 0 = [] constructLRs 1 = [[]]@@ -205,8 +247,12 @@   datatypeName <-     case info of       DataConI _ _ n _ -> return n-      _ -> fail $ nameBase conName ++ " is not a data constructor"-  TyConI (DataD _ _ _ cons _) <- reify datatypeName+      _ -> fail $ "‘" ++ nameBase conName ++ "’ is not a data constructor"+  typeInfo <- reify datatypeName+  let cons = case typeInfo of+               TyConI (DataD _ _ _ cons _)   -> cons+               TyConI (NewtypeD _ _ _ con _) -> [con]+               _                             -> []   return $ constructLRs (length cons) !!              fromJust (List.findIndex (== conName) (map (\con -> case con of { NormalC n _ -> n; RecC n _ -> n}) cons)) @@ -216,8 +262,12 @@   datatypeName <-     case info of       DataConI _ _ n _ -> return n-      _ -> fail $ nameBase conName ++ " is not a data constructor"-  TyConI (DataD _ _ _ cons _) <- reify datatypeName+      _ -> fail $ "‘" ++ nameBase conName ++ "’ is not a data constructor"+  typeInfo <- reify datatypeName+  let cons = case typeInfo of+               TyConI (DataD _ _ _ cons _)   -> cons+               TyConI (NewtypeD _ _ _ con _) -> [con]+               _                             -> []   return $ (\(RecC _ fs) -> length fs) (fromJust (List.find (\(RecC n _) -> n == conName) cons))  lookupRecordField :: Name -> Name -> Q Int@@ -226,36 +276,34 @@   datatypeName <-     case info of       DataConI _ _ n _ -> return n-      _ -> fail $ nameBase conName ++ " is not a data constructor"-  TyConI (DataD _ _ _ cons _) <- reify datatypeName+      _ -> fail $ "‘" ++ nameBase conName ++ "’ is not a data constructor"+  typeInfo <- reify datatypeName+  let cons = case typeInfo of+               TyConI (DataD _ _ _ cons _)   -> cons+               TyConI (NewtypeD _ _ _ con _) -> [con]+               _                             -> []   case (List.findIndex (\(n,_,_) -> n == fieldName) ((\(RecC _ fs) -> fs) $ fromJust (List.find (\(RecC n _) -> n == conName) cons))) of        Just res -> return res-       Nothing -> fail $ nameBase fieldName ++ " is not a field in " ++ nameBase conName-+       Nothing -> fail $ "‘" ++ nameBase fieldName ++ "’ is not a field in ‘" ++ nameBase conName ++ "’"  mkConstrutorFromLRs :: [ConTag] -> PatTag -> Q (Exp -> Exp)-mkConstrutorFromLRs lrs patTag = do (_, [gin, gleft, gright]) <- lookupNames [] [ "Generics.BiGUL.AST." ++ show patTag ++ s | s <- ["In", "Left", "Right"] ] "cannot find data constructors *what* from Generic.BiGUL.AST"-                                    return $ foldl (.) (AppE (ConE gin)) (map (AppE . ConE . contag gleft gright) lrs)---astNameSpace :: String-astNameSpace = "Generics.BiGUL.AST."+mkConstrutorFromLRs lrs patTag = do+  (_, [gin, gleft, gright]) <- lookupNames astNamespace [] (map (show patTag ++) ["In", "Left", "Right"])+  return (foldl (.) (AppE (ConE gin)) (map (AppE . ConE . contag gleft gright) lrs)) --- | mkPat :: TH.Pat -> PatTag -> [Name] -> Q TH.Exp  mkPat (LitP c) patTag _ = do-  (_, [gconst]) <- lookupNames [] [astNameSpace ++ show patTag ++ "Const"] (notFoundMsg $ show patTag ++ "Const")+  (_, [gconst]) <- lookupNames astNamespace [] [show patTag ++ "Const"]   return $ ConE gconst `AppE` LitE c - -- user defined datatypes && unit pattern mkPat (ConP name ps) patTag dupnames = do   ConP name' [] <- [p| () |]   if name == name' && ps == []   then do        unitt         <- [| () |]-       (_, [gconst]) <- lookupNames [] [astNameSpace ++ show patTag ++ s | s <- ["Const"]] (notFoundMsg $ show patTag ++ "Const")+       (_, [gconst]) <- lookupNames astNamespace [] [show patTag ++ "Const"]        return $ ConE gconst `AppE` unitt   else do        lrs <- lookupLRs name@@ -265,8 +313,6 @@                        _  -> mkPat (TupP ps)  patTag dupnames        return $ conInEither pes -- mkPat (RecP name ps) patTag dupnames = do   -- reduce the case for a record constructor to the case for an ordinary constructor   len <- lookupRecordLength name -- number of constructor arguments@@ -280,14 +326,13 @@                               | otherwise = helper (i+1) n pairs (acc++[findInPair pairs i])         -- let ips = zip indexs nps in [ maybe WildP id (List.lookup i ips) | i <- [0..len-1] ] - mkPat (ListP []) patTag dupnames = do emptyp <- [p| [] |]                                       mkPat emptyp patTag dupnames  mkPat (ListP (p:xs)) patTag dupnames = do   hexp <- mkPat p patTag dupnames   rexp <- mkPat (ListP xs) patTag dupnames-  (_, [gin,gright,gprod]) <- lookupNames [] [astNameSpace ++ show patTag ++ s | s <- ["In","Right","Prod"]] (notFoundMsg $ (concatWith " ". map (withPatTag patTag)) ["In","Right","Prod"])+  (_, [gin,gright,gprod]) <- lookupNames astNamespace [] (map (show patTag ++) ["In", "Right", "Prod"])   return $ ConE gin `AppE` (ConE gright `AppE` (ConE gprod `AppE` hexp `AppE` rexp))  mkPat (InfixP pl name pr) patTag dupnames = do@@ -295,60 +340,41 @@   if name == name'   then do lpat <- mkPat pl patTag dupnames           rpat <- mkPat pr patTag dupnames-          (_, [gin,gright,gprod]) <- lookupNames [] [astNameSpace ++ show patTag ++ s | s <- ["In","Right","Prod"]] (notFoundMsg $ (concatWith " ". map (withPatTag patTag)) ["In","Right","Prod"])+          (_, [gin,gright,gprod]) <- lookupNames astNamespace [] (map (show patTag ++) ["In", "Right", "Prod"])           return $ ConE gin `AppE` (ConE gright `AppE` (ConE gprod `AppE` lpat `AppE` rpat))-  else fail $ "constructors mismatch: " ++ nameBase name ++ " and " ++ nameBase name'-+  else fail $ "Infix use of ‘" ++ nameBase name ++ "’ is not supported"  mkPat (TupP [p]) patTag dupnames = mkPat p patTag dupnames+ mkPat (TupP (p:ps)) patTag dupnames = do   lexp <- mkPat p patTag dupnames   rexp <- mkPat (TupP ps) patTag dupnames-  (_, [gprod]) <- lookupNames [] [astNameSpace ++ show patTag ++ s | s <- ["Prod"]] (notFoundMsg "Prod")+  (_, [gprod]) <- lookupNames astNamespace [] [show patTag ++ "Prod"]   return ((ConE gprod `AppE` lexp) `AppE` rexp) -+mkPat (WildP) RTag _ = fail $ "Wildcard (‘_’) is forbidden in a view-rearranging pattern" -mkPat (WildP) RTag _ = fail $ "Wildcard(_) connot be used in lambda pattern expression." mkPat (WildP) STag _ = do-  (_, [pvar'])       <- lookupNames [] [astNameSpace ++ "PVar'"] (notFoundMsg "PVar'")+  (_, [pvar'])       <- lookupNames astNamespace [] ["PVar'"]   return $ ConE pvar' - mkPat (VarP name) _  dupnames =  do-  (_, [pvar,pvar'])       <- lookupNames [] [ astNameSpace ++ s | s <- ["PVar", "PVar'"] ] (notFoundMsg "PVar,PVar'")+  (_, [pvar,pvar'])       <- lookupNames astNamespace [] ["PVar", "PVar'"]   return $ if name `elem` dupnames then ConE pvar else ConE pvar' ---mkPat _ patTag _ = fail $ "Pattern not handled yet."-------+mkPat _ patTag _ = fail "Unsupported pattern in a rearranging lambda-expression"   -- | translate all (VarE name) to directions using env rearrangeExp :: Exp -> Map String Exp -> Q Exp-rearrangeExp (VarE name) env  =+rearrangeExp (VarE name)  env =   case Map.lookup (nameBase name) env of     Just val -> return val-    Nothing  -> fail $ "cannot find name " ++ nameBase name ++ " in env."+    Nothing  -> fail $ "Panic: Unbound variable ‘" ++ nameBase name ++ "’" rearrangeExp (AppE e1 e2) env = liftM2 AppE (rearrangeExp e1 env) (rearrangeExp e2 env)-rearrangeExp (ConE name) env  = return $ ConE name-rearrangeExp (LitE c)    env  = return $ LitE c-rearrangeExp _           env  = fail $ "Invalid representation of bigul program in TemplateHaskell ast"--------+rearrangeExp (ConE name)  env = return $ ConE name+rearrangeExp (LitE c)     env = return $ LitE c+rearrangeExp _            env = fail "Unsupported expression in a rearranging lambda-expression"  mkEnvForRearr :: TH.Pat -> Q (Map String Exp) mkEnvForRearr (LitP c) = return Map.empty@@ -369,21 +395,21 @@  mkEnvForRearr (ListP []) = return Map.empty mkEnvForRearr (ListP (pl:pr))     = do-  (_, [dleft,dright]) <- lookupNames [] [ astNameSpace ++ s | s <- ["DLeft", "DRight"] ] (notFoundMsg "DLeft, DRight")+  (_, [dleft,dright]) <- lookupNames astNamespace [] ["DLeft", "DRight"]   lenv <- mkEnvForRearr pl   renv <- mkEnvForRearr (ListP pr)   return $ Map.map (ConE dleft `AppE`) lenv `Map.union`           Map.map (ConE dright `AppE`) renv  mkEnvForRearr (InfixP pl name pr) = do-  (_, [dleft,dright]) <- lookupNames [] [ astNameSpace ++ s | s <- ["DLeft", "DRight"] ] (notFoundMsg "DLeft, DRight")+  (_, [dleft,dright]) <- lookupNames astNamespace [] ["DLeft", "DRight"]   lenv <- mkEnvForRearr pl   renv <- mkEnvForRearr pr-  return $ Map.map (ConE dleft `AppE`) lenv `Map.union`-          Map.map (ConE dright `AppE`) renv+  return $ Map.map (ConE dleft  `AppE`) lenv `Map.union`+           Map.map (ConE dright `AppE`) renv  mkEnvForRearr (TupP ps) = do-  (_, [dleft,dright]) <- lookupNames [] [ astNameSpace ++ s | s <- ["DLeft", "DRight"] ] (notFoundMsg "DLeft, DRight")+  (_, [dleft,dright]) <- lookupNames astNamespace [] ["DLeft", "DRight"]   subenvs             <- mapM mkEnvForRearr ps   let envs            =  zipWith (Map.map . foldr (.) id . map (AppE . ConE . contag dleft dright))                                  (constructLRs (length ps)) subenvs@@ -392,13 +418,10 @@ mkEnvForRearr WildP = return Map.empty  mkEnvForRearr (VarP name) = do-  (_, [dvar]) <- lookupNames [] [ astNameSpace ++ s | s <- ["DVar"] ] (notFoundMsg "DVar")+  (_, [dvar]) <- lookupNames astNamespace [] ["DVar"]   return $ Map.singleton (nameBase name) (ConE dvar) -mkEnvForRearr  _    =  fail $ "Pattern not handled yet."---+mkEnvForRearr  _    =  fail "Unsupported pattern in a rearranging lambda-expression"   splitDataAndCon:: TH.Exp -> Q (TH.Exp -> TH.Exp ,[TH.Exp])@@ -414,14 +437,13 @@   d        <- mkBodyExpForRearr e2   return (c,ds++[d]) -splitDataAndCon _            =  fail $ "Invalid data constructor in lambda body expression"-+splitDataAndCon _            =  fail "Invalid data constructor in a rearranging lambda-expression"   mkBodyExpForRearr :: TH.Exp -> Q TH.Exp  mkBodyExpForRearr (LitE c) = do-  (_, [econst]) <- lookupNames [] [astNameSpace ++ "EConst"] (notFoundMsg "EConst")+  (_, [econst]) <- lookupNames astNamespace [] ["EConst"]   return $ ConE econst `AppE` (LitE c)  mkBodyExpForRearr (VarE name) =  return $ VarE name@@ -429,15 +451,14 @@ mkBodyExpForRearr (AppE e1 e2) = do   -- must be constructor applied to arguments (rearrangement expression does not allow general functions)   -- surface syntax is curried constructor applied to arguments in order; should translate that to uncurried constructor applied to a tuple of arguments-  (_, [eprod]) <- lookupNames [] [astNameSpace ++ "EProd"] (notFoundMsg "EProd")+  (_, [eprod]) <- lookupNames astNamespace [] ["EProd"]   (con, ds)   <- splitDataAndCon (AppE e1 e2)   return $ con (foldr1 (\d1 d2 -> ConE eprod `AppE` d1 `AppE` d2) ds) - mkBodyExpForRearr (ConE name) =  do   -- must be constructor without argument   (ConE name') <- [| () |]-  (_, [econst]) <- lookupNames [] [astNameSpace ++ s | s <- ["EConst"] ] (notFoundMsg "EConst")+  (_, [econst]) <- lookupNames astNamespace [] ["EConst"]   if name == name'   then return $ ConE econst `AppE` (ConE name)   else mkBodyExpForRearr (AppE (ConE name) (ConE name'))@@ -445,7 +466,7 @@ mkBodyExpForRearr (RecConE name es) = do   -- reduce to the case for ordinary constructors   (ConE name') <- [| () |]-  (_, [econst,eprod]) <- lookupNames [] [astNameSpace ++ s | s <- ["EConst","EProd"]] (notFoundMsg "EConst and EProd")+  (_, [econst,eprod]) <- lookupNames astNamespace [] ["EConst", "EProd"]   len <- lookupRecordLength name   indexs <- mapM (\(n,_) -> lookupRecordField name n) es   let nes =  map snd es@@ -462,37 +483,33 @@   if name == name'   then do le <- mkBodyExpForRearr e1           re <- mkBodyExpForRearr e2-          (_, [ein,eright,eprod]) <- lookupNames [] [astNameSpace ++ s | s <- ["EIn","ERight","EProd"]] (notFoundMsg "EIn, ERight, EProd")+          (_, [ein,eright,eprod]) <- lookupNames astNamespace [] ["EIn", "ERight", "EProd"]           return $ ConE ein `AppE` (ConE eright `AppE` (ConE eprod `AppE` le `AppE` re))-  else fail $ "only (:) infix operator is allowed in lambda body expression"+  else fail $ "Infix use of ‘" ++ nameBase name ++ "’ is not supported"  mkBodyExpForRearr (ListE [])  = do   unitt                   <- [| () |]-  (_, [ein,eleft,econst]) <- lookupNames [] [astNameSpace ++ s | s <- ["EIn","ELeft","EConst"]] (notFoundMsg "EIn, ELeft, EConst")+  (_, [ein,eleft,econst]) <- lookupNames astNamespace [] ["EIn", "ELeft", "EConst"]   return $ ConE ein `AppE` (ConE eleft `AppE` (ConE econst `AppE` unitt)) mkBodyExpForRearr (ListE (e:es)) = do   hexp <- mkBodyExpForRearr e   rexp <- mkBodyExpForRearr (ListE es)-  (_, [ein,eright,eprod]) <- lookupNames [] [astNameSpace ++ s | s <- ["EIn","ERight","EProd"]] (notFoundMsg "EIn, ERight, EProd")+  (_, [ein,eright,eprod]) <- lookupNames astNamespace [] ["EIn", "ERight", "EProd"]   return $ ConE ein `AppE` (ConE eright `AppE` (ConE eprod `AppE` hexp `AppE` rexp))  mkBodyExpForRearr (TupE [e])    = mkBodyExpForRearr e mkBodyExpForRearr (TupE (e:es)) = do   lexp <- mkBodyExpForRearr e   rexp <- mkBodyExpForRearr (TupE es)-  (_, [eprod]) <- lookupNames [] [astNameSpace ++ "EProd"] (notFoundMsg "EProd")+  (_, [eprod]) <- lookupNames astNamespace [] ["EProd"]   return ((ConE eprod `AppE` lexp) `AppE` rexp)-mkBodyExpForRearr _           = fail $ "Invalid syntax in lambda body expression"----+mkBodyExpForRearr _           = fail "Unsupported expression in a rearranging lambda-expression"   rearr' :: PatTag -> TH.Exp -> [Name] -> Q TH.Exp rearr' patTag (LamE [p] e) dupnames = do   let suffixRS = case patTag of {RTag -> "V" ; STag -> "S" ; _ -> ""}-  (_, [edir,rearrc]) <- lookupNames [] [astNameSpace ++ s | s <- ["EDir","Rearr"++suffixRS] ] (notFoundMsg $ "EDir, Rearr"++suffixRS)+  (_, [edir,rearrc]) <- lookupNames astNamespace [] ["EDir", "Rearr" ++ suffixRS]   pat <- mkPat p patTag dupnames   exp <- mkBodyExpForRearr e   env <- mkEnvForRearr p@@ -508,24 +525,52 @@ getAllVars (InfixE (Just e1) (ConE name) (Just e2)) = getAllVars e1 ++ getAllVars e2 getAllVars (ListE es) = concatMap getAllVars es getAllVars (TupE  es) = concatMap getAllVars es-getAllVars  _         =  fail $ "Invalid exp in getAllVars"---rearrV :: Q TH.Exp -> Q TH.Exp-rearrV qlambexp = do lambexp@(LamE _ e) <- qlambexp-                     let varnames = getAllVars e-                     rearr' RTag lambexp (varnames \\ (nub varnames))--rearrS :: Q TH.Exp -> Q TH.Exp-rearrS qlambexp = do lambexp@(LamE _ e) <- qlambexp-                     let varnames = getAllVars e-                     rearr' STag lambexp (varnames \\ (nub varnames))----+getAllVars  _         =  fail "Unsupported expression in a rearranging lambda-expression" +-- | A higher-level syntax for 'Generics.BiGUL.RearrS',+--   allowing its first and second arguments to be specified in terms of a simple lambda-expression.+--   The usual way of using 'rearrS' is+--+--   > $(rearrS [| f |]) b :: BiGUL s v+--+--   where @f :: s -> s'@ is a simple lambda-expression and @b :: BiGUL s' v@ an inner program.+rearrS :: Q TH.Exp  -- ^ rearranging lambda-expression+       -> Q TH.Exp+rearrS qlambexp = do+  lambexp <- qlambexp+  case lambexp of+    LamE [_] e ->+      let varnames = getAllVars e+      in  rearr' STag lambexp (varnames \\ nub varnames)+    LamE _   _ ->+      fail "A rearranging lambda-expression should have exactly one argument"+    _          ->+      fail "The first argument to rearrS should be a (quoted) lambda-expression" +-- | A higher-level syntax for 'Generics.BiGUL.RearrV',+--   allowing its first and second arguments to be specified in terms of a simple lambda-expression.+--   The usual way of using 'rearrV' is+--+--   > $(rearrV [| f |]) b :: BiGUL s v+--+--   where @f :: v -> v'@ is a simple lambda-expression and @b :: BiGUL s v'@ an inner program.+--   In @f@, wildcard ‘@_@’ is not allowed, and all pattern variables must be used in the body.+--   (This is for ensuring that the view information is fully embedded into the source.)+rearrV :: Q TH.Exp  -- ^ rearranging lambda-expression+       -> Q TH.Exp+rearrV qlambexp = do+  lambexp <- qlambexp+  case lambexp of+    LamE [p] e ->+      let varnames = getAllVars e+          unusedVars = namesBoundInPat p \\ varnames+      in  if null unusedVars+          then rearr' RTag lambexp (varnames \\ nub varnames)+          else fail $ "Variable(s) unused in the body of a view-rearranging lambda-expression: " +++                      concat (intersperse ", " (map nameBase unusedVars))+    LamE _   _ -> fail "A rearranging lambda-expression should have exactly one argument"+    _          ->+      fail "The first argument to rearrV should be a (quoted) lambda-expression"  mkExpFromPat :: TH.Pat -> Q TH.Exp mkExpFromPat (LitP c) = return (LitE c)@@ -548,25 +593,25 @@   return (TupE es) mkExpFromPat (VarP name) = return (VarE name) mkExpFromPat WildP = [| () |]-mkExpFromPat _ = fail $ "pattern not handled in mkExpFromPat"+mkExpFromPat _ = fail "Unsupported pattern in a rearranging lambda-expression"  mkExpFromPat' :: TH.Pat -> Q TH.Exp-mkExpFromPat' (ConP name ps ) = do (_, [replace]) <- lookupNames [] [astNameSpace ++ "Replace"] (notFoundMsg "Replace")+mkExpFromPat' (ConP name ps ) = do (_, [replace]) <- lookupNames astNamespace [] ["Replace"]                                    ConP name' [] <- [p| () |]                                    if name == name' && ps == []                                    then return (ConE replace)-                                   else  fail $ "rearrSV only supports tuple"+                                   else fail $ "Panic: rearrSV only supports tuple" mkExpFromPat' (VarP name) = return (VarE name) mkExpFromPat' (TupP ps) = do-  (_, [prod]) <- lookupNames [] [ astNameSpace ++ "Prod" ] (notFoundMsg "Prod")+  (_, [prod]) <- lookupNames astNamespace [] ["Prod"]   es <- mapM mkExpFromPat' ps   return $ foldr1 (\e1 e2 -> ((ConE prod `AppE` e1) `AppE` e2)) es-mkExpFromPat' _ = fail $ "rearrSV only supports tuple"+mkExpFromPat' _ = fail $ "Panic: rearrSV only supports tuple"  toProduct :: TH.Exp -> Q TH.Exp toProduct (AppE e1 e2) = do   (ConE unitn) <- [| () |]-  (_, [econst,ein,eleft,eright]) <- lookupNames [] [ astNameSpace ++ s | s <- ["EConst","EIn","ELeft", "ERight"] ] (notFoundMsg "EConst, EIn, ELeft, ERight")+  (_, [econst,ein,eleft,eright]) <- lookupNames astNamespace [] ["EConst", "EIn", "ELeft", "ERight"]   re2 <- toProduct e2   re1 <- toProduct e1   if e1 == (ConE eleft) || e1 == (ConE eright) || e1 == (ConE ein)@@ -574,12 +619,8 @@   else if e1 == (ConE econst)        then return (AppE e1 (ConE unitn))        else return (AppE re1 re2)-- toProduct other = return other -- mkProdPatFromSHelper :: TH.Pat -> Q TH.Pat mkProdPatFromSHelper (TupP []) = [p| () |] mkProdPatFromSHelper other     = return other@@ -606,18 +647,21 @@   mkProdPatFromSHelper (TupP es) mkProdPatFromS (VarP name) = return (VarP name) mkProdPatFromS WildP = [p| () |]-mkProdPatFromS _ = fail $ "pattern not handled in mkProdPatFromS"+mkProdPatFromS _ = fail "Unsupported pattern in a rearranging lambda-expression"  -- | Example: rearrSV [p| x:xs |] [p| x:xs |] [p| (x,xs) |] [d| x = Replace; xs = rec |] --   generates a rearrS from the first  pattern and the third pattern --         and a rearrV from the second pattern and the third pattern rearrSV :: Q TH.Pat -> Q TH.Pat -> Q TH.Pat -> Q [TH.Dec] -> Q TH.Exp rearrSV qsp qvp qpp qpd = do-  (_, [edir,rearrs,rearrv]) <- lookupNames [] [astNameSpace ++ s | s <- ["EDir","RearrS","RearrV"] ] (notFoundMsg "EDir, RearrS, RearrV")+  (_, [edir,rearrs,rearrv]) <- lookupNames astNamespace [] ["EDir", "RearrS", "RearrV"]   sp <- qsp   vp <- qvp   pp <- qpp   pd <- qpd+  prodenv <-  mkEnvForUpdate pd+  let namesInPat = sort . map nameBase . namesBoundInPat+  checkVars (namesInPat sp) (namesInPat vp) (namesInPat pp) (Map.keys prodenv)   spat <- mkPat sp STag []   vpat <- mkPat vp RTag []   commonexp <- mkExpFromPat pp@@ -628,125 +672,158 @@   venv <- mkEnvForRearr vp   vbody <- rearrangeExp commonexp'' (Map.map (ConE edir `AppE`) venv)   prodexp <- mkExpFromPat' pp-  prodenv <-  mkEnvForUpdate pd   prodbigul <- rearrangeExp prodexp prodenv   return $ ((ConE rearrs `AppE` spat) `AppE` sbody) `AppE` (((ConE rearrv `AppE` vpat) `AppE` vbody) `AppE` prodbigul)-+  where+    checkVars :: [String] -> [String] -> [String] -> [String] -> Q ()+    checkVars svars vvars cvars dvars | svars /= vvars =+      fail "Source and view patterns should have the same variables"+    checkVars svars vvars cvars dvars | svars /= cvars =+      fail "The common pattern should have the same variables as the source/view patterns"+    checkVars svars vvars cvars dvars | svars /= dvars =+      fail "The declaration list should include exactly the variables in the source/view patterns"+    checkVars svars vvars cvars dvars | otherwise      = return () -update  :: Q TH.Pat -> Q TH.Pat -> Q [TH.Dec] -> Q TH.Exp-update = \pv ps d -> rearrSV ps pv (ps >>= mkProdPatFromS) d+-- | A succinct syntax dealing with the frequently occurring situation where both the source and view+--   are rearranged into products and their components further synchronised by inner updates.+--   For example, the program+--+--   > $(update [p| x:xs |] [p| x:xs |] [d| x = Replace; xs = b |]) :: BiGUL [a] [a]+--+--   matches both the source and view lists with a cons pattern, marking their head and tail as @x@ and @xs@ respectively,+--   and synchronises the heads using @Replace@ (which is the program associated with @x@ in the declaration list)+--   and the tails using some @b :: BiGUL [a] [a]@. In short, the program is equivalent to+--+--   > $(rearrS [| \(x:xs) -> (x, xs) |])$+--   >   $(rearrV [| \(x:xs) -> (x, xs) |])$+--   >     Replace `Prod` b+--+--   (Admittedly, it is an abuse of syntax to represent a list of named BiGUL programs in terms of a declaration list,+--   but it is the closest thing we can find that works directly with Template Haskell.)+update :: Q TH.Pat    -- ^ source pattern+       -> Q TH.Pat    -- ^ view pattern+       -> Q [TH.Dec]  -- ^ named updates (as a declaration list)+       -> Q TH.Exp+update ps pv d = rearrSV ps pv (ps >>= mkProdPatFromS) d  mkEnvForUpdate :: [TH.Dec] -> Q (Map String TH.Exp) mkEnvForUpdate []                                     = return Map.empty mkEnvForUpdate ((ValD (VarP name) (NormalB e) _ ):ds) = do   renv <- mkEnvForUpdate ds   return $ Map.singleton (nameBase name) e `Map.union` renv-mkEnvForUpdate (_:ds) = fail $ "Invalid syntax in update bindings\n" ++-                               "Please use syntax like x1 = e1 x2 = e2... here"--{--update :: Q TH.Pat -> Q [TH.Dec] -> Q TH.Exp-update qp qds = do-  (_, [upd]) <- lookupNames [] [astNameSpace ++ "Update"] (notFoundMsg "Update")-  p   <- qp-  ds  <- qds-  pat <- mkPat p UTag-  env <- mkEnvForUpdate ds-  rearrangeExp (ConE upd `AppE` pat) env--}----patToFunc :: TH.Pat -> Q TH.Exp-patToFunc p =  do-  (_, [htrue,hfalse]) <- lookupNames [] ["True","False"] (notFoundMsg "True,False")-  name                        <-  newName "x"-  case p of-    TH.WildP -> return $ LamE [VarP name] (ConE htrue)-    _        -> return $ LamE [VarP name] (CaseE (VarE name)-                        [Match p (NormalB (ConE htrue)) [], Match WildP (NormalB (ConE hfalse)) []])---------notFoundMsg :: String -> String-notFoundMsg s = "cannot find data constructors " ++ s ++ " from Generic.BiGUL.AST"+mkEnvForUpdate (_:ds) = fail "Invalid syntax in update bindings (write ‘x1 = e1; x2 = e2; ...’)" -withPatTag :: PatTag -> String -> String-withPatTag tag con = show tag ++ con+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)) []]) -concatWith :: String -> [String] -> String-concatWith sep [] = ""-concatWith sep (x:xs) = x ++ sep ++ concatWith sep xs+nameAdaptive :: Q TH.Exp+nameAdaptive = lookupNames astNamespace [] ["Adaptive"] >>= \(_, [badaptive]) -> conE badaptive +nameNormal :: Q TH.Exp+nameNormal = lookupNames astNamespace [] ["Normal"] >>= \(_, [bnormal]) -> conE bnormal  class ExpOrPat a where-  toExp :: a -> TH.ExpQ+  toExp :: a -> Q TH.Exp -instance ExpOrPat (TH.ExpQ) where+instance ExpOrPat (Q TH.Exp) where   toExp = id -instance ExpOrPat (TH.PatQ) where-  toExp = (>>= patToFunc)---- $(normal [| predicateOnSV |]) b---   ~>  (predicateOnSV, Normal b (const True))-normal :: TH.ExpQ -> TH.ExpQ-normal psv = [|\b -> ($psv, $(nameNormal) b (const True))|]----- $(normal' [| predicateOnSV |] [| predictionPredicate |]) b---   ~>  (predicateOnSV, Normal b predictionPredicate)-normal' :: ExpOrPat a => TH.ExpQ -> a -> TH.ExpQ-normal' psv pp = [|\b -> ($psv, $(nameNormal) b $(toExp pp)) |]----- $(normalS [| predicateOnS |]) b---   ~>  ((\s _ -> predicateOnS s), Normal b predicateOnS)-normalS :: ExpOrPat a => a -> TH.ExpQ-normalS ps = [|\b -> (\s _ -> $(toExp ps) s, $(nameNormal) b $(toExp ps)) |]---- $(normalV [| predicateOnV |]) b---   ~>  ((\_ v -> predicateOnV v), Normal b (const True))-normalV :: ExpOrPat a => a -> TH.ExpQ-normalV pv = [|\b -> (\_ v -> $(toExp pv) v, $(nameNormal) b (const True)) |]---- $(normalV' [| predicateOnV |] [| predictionPredicate |]) b---   ~>  ((\_ v -> predicateOnV v), Normal b predictionPredicate)-normalV' :: (ExpOrPat a, ExpOrPat b) => a -> b -> TH.ExpQ-normalV' pv pp = [|\b -> (\_ v -> $(toExp pv) v, $(nameNormal) b $(toExp pp)) |]---- $(normalSV [| predicateOnS |] [| predicateOnV |]) b---   ~>  ((\s v -> predicateOnS s && predicateOnV v), Normal b predicateOnS)-normalSV :: (ExpOrPat a, ExpOrPat b) => a -> b -> TH.ExpQ-normalSV ps pv = [|\b -> (\s v -> $(toExp ps) s && $(toExp pv) v, $(nameNormal) b $(toExp ps)) |]---- $(adaptive [| predicateOnSV |]) f---   ~> (predicateOnSV, Adaptive f)-adaptive :: TH.ExpQ -> TH.ExpQ-adaptive psv = [| \f -> ($psv, $(nameAdaptive) f) |]---- $(adaptiveS [| predicateOnS |]) f---   ~> ((\s _ -> predicateOnS s), Adaptive f)-adaptiveS :: ExpOrPat a => a -> TH.ExpQ-adaptiveS ps = [| \f -> (\s _ -> $(toExp ps) s, $(nameAdaptive) f) |]---- $(adaptiveV [| predicateOnV |]) f---   ~> ((\_ v -> predicateOnV v), Adaptive f)-adaptiveV :: ExpOrPat a => a -> TH.ExpQ-adaptiveV pv = [| \f -> (\_ v -> $(toExp pv) v, $(nameAdaptive) f) |]+instance ExpOrPat (Q TH.Pat) where+  toExp = (>>= patCond) --- $(adaptiveSV [| predicateOnS |] [| predicateOnV |]) f---   ~> ((\s v -> predicateOnS s && predicateOnV v), Adaptive f)-adaptiveSV :: (ExpOrPat a, ExpOrPat b) => a -> b -> TH.ExpQ-adaptiveSV ps pv = [| \f -> (\s v -> $(toExp ps) s && $(toExp pv) v, $(nameAdaptive) f) |]+patLambdaToPred :: TH.Exp -> Q TH.Exp+patLambdaToPred p =+  case p of+    LamE [pat] body -> do+      (_, [hmaybe, hFalse, hid, hreturn]) <-lookupNames "Prelude" [] ["maybe", "False", "id", "return"]+      [| \x -> $(varE hmaybe) $(conE hFalse) $(varE hid) $(doExp hreturn pat [| x |] body) |]+    LamE [spat, vpat] body -> do+      (_, [hmaybe, hFalse, hid, hreturn]) <-lookupNames "Prelude" [] ["maybe", "False", "id", "return"]+      [| \s v -> $(varE hmaybe) $(conE hFalse) $(varE hid) $(doExp hreturn (TupP [spat, vpat]) [| (s, v) |] body) |]+    _ -> return p+  where+    doExp :: TH.Name -> TH.Pat -> Q TH.Exp -> TH.Exp -> Q TH.Exp+    doExp hreturn p qMatchExp boolExp = do+      matchExp <- qMatchExp+      return (DoE [BindS p (VarE hreturn `AppE` matchExp),+                   NoBindS (VarE hreturn `AppE` boolExp)]) +-- | Construct a normal branch, for which a main condition on the source and view and+--   an exit condition on the source should be specified. The usual way of using 'normal' is+--+--   > $(normal [| p |] [| q |]) b :: CaseBranch s v+--+--   where+--+--   * @p :: s -> v -> Bool@,+--+--   * @q :: s -> Bool@, and+--+--   * @b :: BiGUL s v@, which is the branch body.+normal :: ExpOrPat a+       => Q TH.Exp  -- ^ main condition (binary predicate on the source and view)+       -> a         -- ^ exit condition (unary predicate on the source)+       -> Q TH.Exp+normal mp mq =+  [| \b -> ($(mp >>= patLambdaToPred), $(nameNormal) b $(toExp mq >>= patLambdaToPred)) |] -nameAdaptive :: TH.ExpQ-nameAdaptive = lookupNames [] [astNameSpace ++ "Adaptive"] (notFoundMsg "Adaptive") >>= \(_, [badaptive]) -> conE badaptive+-- | A special case of 'normal' where the main condition is specified as the conjunction of two unary predicates+--   on the source and view respectively. The usual way of using 'normalSV' is+--+--   > $(normalSV [| ps |] [| pv |] [| q |]) b :: CaseBranch s v+--+--   where+--+--   * @ps :: s -> Bool@,+--+--   * @pv :: v -> Bool@,+--+--   * @q :: s -> Bool@, and+--+--   * @b :: BiGUL s v@, which is the branch body.+normalSV :: (ExpOrPat a, ExpOrPat b, ExpOrPat c)+         => a  -- ^ main source condition (unary predicate on the source)+         -> b  -- ^ main view condition (unary predicate on the view)+         -> 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)) |] -nameNormal :: TH.ExpQ-nameNormal = lookupNames [] [astNameSpace ++ "Normal"] (notFoundMsg "Normal") >>= \(_, [bnormal]) -> conE bnormal+-- | Construct an adaptive branch, for which a main condition on the source and view should be specified.+--   The usual way of using 'adaptive' is+--+--   > $(adaptive [| p |]) f :: CaseBranch s v+--+--   where+--+--   * @p :: s -> v -> Bool@ and+--+--   * @f :: s -> v -> s@, which is the adaptation function.+adaptive :: Q TH.Exp  -- ^ main condition (binary predicate on the source and view)+         -> Q TH.Exp+adaptive mp = [| \f -> ($(mp >>= patLambdaToPred), $(nameAdaptive) f) |] +-- | A special case of 'adaptive' where the main condition is specified as the conjunction of two unary predicates+--   on the source and view respectively. The usual way of using 'adaptiveSV' is+--+--   > $(adaptiveSV [| ps |] [| pv |]) f :: CaseBranch s v+--+--   where+--+--   * @ps :: s -> Bool@,+--+--   * @pv :: v -> Bool@, and+--+--   * @f :: s -> v -> s@, which is the adaptation function.+adaptiveSV :: (ExpOrPat a, ExpOrPat b)+           => a  -- ^ main source condition (unary predicate on the source)+           -> b  -- ^ main view condition (unary predicate on the view)+           -> Q TH.Exp+adaptiveSV ps pv =+  [| \f -> (\s v -> $(toExp ps >>= patLambdaToPred) s && $(toExp pv >>= patLambdaToPred) v, $(nameAdaptive) f) |]