diff --git a/BiGUL.cabal b/BiGUL.cabal --- a/BiGUL.cabal +++ b/BiGUL.cabal @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/src/GHC/InOut.hs b/src/GHC/InOut.hs --- a/src/GHC/InOut.hs +++ b/src/GHC/InOut.hs @@ -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 -- 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) } - diff --git a/src/Generics/BiGUL.hs b/src/Generics/BiGUL.hs new file mode 100644 --- /dev/null +++ b/src/Generics/BiGUL.hs @@ -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` diff --git a/src/Generics/BiGUL/AST.hs b/src/Generics/BiGUL/AST.hs deleted file mode 100644 --- a/src/Generics/BiGUL/AST.hs +++ /dev/null @@ -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 " - -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 " ++ 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 diff --git a/src/Generics/BiGUL/Error.hs b/src/Generics/BiGUL/Error.hs --- a/src/Generics/BiGUL/Error.hs +++ b/src/Generics/BiGUL/Error.hs @@ -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 diff --git a/src/Generics/BiGUL/Interpreter.hs b/src/Generics/BiGUL/Interpreter.hs --- a/src/Generics/BiGUL/Interpreter.hs +++ b/src/Generics/BiGUL/Interpreter.hs @@ -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)) diff --git a/src/Generics/BiGUL/Interpreter/Unsafe.hs b/src/Generics/BiGUL/Interpreter/Unsafe.hs --- a/src/Generics/BiGUL/Interpreter/Unsafe.hs +++ b/src/Generics/BiGUL/Interpreter/Unsafe.hs @@ -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 = diff --git a/src/Generics/BiGUL/Lib.hs b/src/Generics/BiGUL/Lib.hs new file mode 100644 --- /dev/null +++ b/src/Generics/BiGUL/Lib.hs @@ -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 + ] diff --git a/src/Generics/BiGUL/Lib/HuStudies.hs b/src/Generics/BiGUL/Lib/HuStudies.hs new file mode 100644 --- /dev/null +++ b/src/Generics/BiGUL/Lib/HuStudies.hs @@ -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| |]) + ] diff --git a/src/Generics/BiGUL/Lib/List.hs b/src/Generics/BiGUL/Lib/List.hs new file mode 100644 --- /dev/null +++ b/src/Generics/BiGUL/Lib/List.hs @@ -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) + + diff --git a/src/Generics/BiGUL/PatternMatching.hs b/src/Generics/BiGUL/PatternMatching.hs new file mode 100644 --- /dev/null +++ b/src/Generics/BiGUL/PatternMatching.hs @@ -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 diff --git a/src/Generics/BiGUL/TH.hs b/src/Generics/BiGUL/TH.hs --- a/src/Generics/BiGUL/TH.hs +++ b/src/Generics/BiGUL/TH.hs @@ -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) |]