BiGUL (empty) → 0.9.0.0
raw patch · 9 files changed
+1477/−0 lines, 9 filesdep +basedep +containersdep +mtlsetup-changed
Dependencies added: base, containers, mtl, pretty, template-haskell
Files
- BiGUL.cabal +40/−0
- Setup.hs +2/−0
- UNLICENSE +24/−0
- src/GHC/InOut.hs +62/−0
- src/Generics/BiGUL/AST.hs +227/−0
- src/Generics/BiGUL/Error.hs +191/−0
- src/Generics/BiGUL/Interpreter.hs +109/−0
- src/Generics/BiGUL/Interpreter/Unsafe.hs +70/−0
- src/Generics/BiGUL/TH.hs +752/−0
+ BiGUL.cabal view
@@ -0,0 +1,40 @@+name: BiGUL+version: 0.9.0.0+synopsis: The Bidirectional Generic Update Language+description:+ Putback-based bidirectional programming allows the programmer to+ write only one putback transformation, from which the unique+ corresponding forward transformation is derived for free. BiGUL,+ short for the Bidirectional Generic Update Language, is designed to+ be a minimalist putback-based bidirectional programming language.+ BiGUL was originally developed in the dependently typed programming+ language Agda, and its well-behavedness has been completely formally+ verified; this package is the Haskell port of BiGUL.+ .+ For more detail, see the following paper:+ .+ * Hsiang-Shang Ko, Tao Zan, and Zhenjiang Hu. BiGUL: A formally+ verified core language for putback-based bidirectional programming.+ In /Partial Evaluation and Program Manipulation/, PEPM’16,+ pages 61–72. ACM, 2016. <http://dx.doi.org/10.1145/2847538.2847544>.++homepage: http://www.prg.nii.ac.jp/project/bigul/+license: PublicDomain+license-file: UNLICENSE+author: Josh Ko, Tao Zan, Li Liu, Zirun Zhu, Jorge Mendes, and Zhenjiang Hu+maintainer: Josh Ko <hsiang-shang@nii.ac.jp> and Zirun Zhu <zhu@nii.ac.jp>+category: Language, Generics, Lenses+build-type: Simple+cabal-version: >=1.22++library+ exposed-modules: Generics.BiGUL.AST+ Generics.BiGUL.Error+ Generics.BiGUL.Interpreter+ Generics.BiGUL.Interpreter.Unsafe+ Generics.BiGUL.TH+ 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+ hs-source-dirs: src+ default-language: Haskell2010
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ UNLICENSE view
@@ -0,0 +1,24 @@+This is free and unencumbered software released into the public domain.++Anyone is free to copy, modify, publish, use, compile, sell, or+distribute this software, either in source code form or as a compiled+binary, for any purpose, commercial or non-commercial, and by any+means.++In jurisdictions that recognize copyright laws, the author or authors+of this software dedicate any and all copyright interest in the+software to the public domain. We make this dedication for the benefit+of the public at large and to the detriment of our heirs and+successors. We intend this dedication to be an overt act of+relinquishment in perpetuity of all present and future rights to this+software under copyright law.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.++For more information, please refer to <http://unlicense.org/>
+ src/GHC/InOut.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE TypeFamilies, UndecidableInstances, FlexibleInstances, FlexibleContexts, TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Module : GHC.InOut+-- Copyright : (C) 2013 Hugo Pacheco+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Hugo Pacheco <hpacheco@nii.ac.jp>+-- Stability : provisional+--+-- Generic sums of products representation for algebraic data types+-- +--+--+----------------------------------------------------------------------------+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)++class ToFromRep (f :: * -> *) where+ fromRep :: f x -> Flatten f+ toRep :: Flatten f -> f x++type instance Flatten U1 = ()+type instance Flatten (K1 i c) = c+type instance Flatten (M1 i c f) = Flatten f+type instance Flatten (f :+: g) = Either (Flatten f) (Flatten g)+type instance Flatten (f :*: g) = (Flatten f,Flatten g)++instance ToFromRep U1 where+ fromRep U1 = ()+ toRep () = U1+instance ToFromRep (K1 i c) where+ fromRep (K1 c) = c+ toRep c = K1 c+instance ToFromRep f => ToFromRep (M1 i c f) where+ fromRep (M1 f) = fromRep f+ toRep x = M1 $ toRep x+instance (ToFromRep f,ToFromRep g) => ToFromRep (f :+: g) where+ fromRep (L1 f) = Left (fromRep f)+ fromRep (R1 g) = Right (fromRep g)+ toRep (Left x) = L1 (toRep x)+ toRep (Right y) = R1 (toRep y)+instance (ToFromRep f,ToFromRep g) => ToFromRep (f :*: g) where+ fromRep (f :*: g) = (fromRep f,fromRep g)+ toRep (f,g) = (toRep f :*: toRep g)++instance (Generic a,ToFromRep (Rep a)) => InOut a where+ inn = to . toRep+ out = fromRep . from++--instance InOut [a] where+-- inn s = either (\() -> []) (\(x,xs) -> x:xs) s+-- out l = case l of { [] -> Left (); (x:xs) -> Right (x,xs) }+
+ src/Generics/BiGUL/AST.hs view
@@ -0,0 +1,227 @@+module Generics.BiGUL.AST+ (BiGUL(..), CaseBranch(..), Pat(..), Direction(..), Expr(..),+ deconstruct, construct, eval, uneval, emptyContainer, fromContainerS, fromContainerV) where++import Generics.BiGUL.Error+import Control.Monad.Except+import GHC.InOut+import Data.List(intersperse)+++data CaseBranch s v = Normal (BiGUL s v) (s -> Bool) | Adaptive (s -> v -> s)++instance Show (CaseBranch s v) where+ show (Normal bigul _) = "Normal " ++ show bigul+ show (Adaptive _ ) = "Adaptive <adaptive function>"++data BiGUL :: * -> * -> * where+ Fail :: String -> BiGUL s v+ Skip :: BiGUL s ()+ Replace :: BiGUL s s+ Prod :: BiGUL s v -> BiGUL s' v' -> BiGUL (s, s') (v, v')+ RearrS :: Pat s env con -> Expr env s' -> BiGUL s' v -> BiGUL s v+ RearrV :: Pat v env con -> Expr env v' -> BiGUL s v' -> BiGUL s v+ Dep :: (Eq v') => BiGUL s v -> (s -> v -> v') -> BiGUL s (v, v')+ Case :: [(s -> v -> Bool, CaseBranch s v)] -> BiGUL s v+ Compose :: BiGUL s u -> BiGUL u v -> BiGUL s v++infixr 1 `Prod`++instance Show (BiGUL s v) where+ show (Fail s) = "Fail: " ++ s+ show Skip = "Skip"+ show Replace = "Replace"+ show (Dep b _) = "(Dep <dependency function> " ++ show b ++ ")"+ show (Case bs) = "(Case [" ++ unwords (intersperse "\n" (map (\(_,b) -> "(predicate, " ++ show b ++ ")") bs)) ++ " ])"+ show _ = "Unknown BiGUL program in show"++newtype Var a = Var a++instance Show a => Show (Var a) where+ show (Var a) = "Var: " ++ show a++-- Pat (view type) (environment type) (container type)+data Pat :: * -> * -> * -> * where+ PVar :: Eq a => Pat a (Var a) (Maybe a)+ PVar' :: Pat a (Var a) (Maybe a)+ PConst :: (Eq a) => a -> Pat a () ()+ PProd :: Pat a a' a'' -> Pat b b' b'' -> Pat (a, b) (a', b') (a'', b'')+ PLeft :: Pat a a' a'' -> Pat (Either a b) a' a''+ PRight :: Pat b b' b'' -> Pat (Either a b) b' b''+ PIn :: InOut a => Pat (F a) b c -> Pat a b c++instance Show (Pat v e c) where+ show PVar = "PVar"+ show PVar' = "PVar'"+ show (PConst c) = "PConst"+ show (PProd rp1 rp2) = "(PProd " ++ show rp1 ++ " " ++ show rp2 ++ ")"+ show (PLeft rp) = "(PLeft " ++ show rp ++ ")"+ show (PRight rp) = "(PRight " ++ show rp ++ ")"+ show (PIn rp) = "(PIn " ++ show rp ++ ")"+ -- show _ = "show error in Pat"++deconstruct :: Pat a env con -> a -> Either (PatExprDirError a) env+deconstruct PVar a = return (Var a)+deconstruct PVar' a = return (Var a)+deconstruct (PConst c) a = if c == a then return () else throwError PEDConstantMismatch+deconstruct (PProd patl patr) (al, ar) = liftM2 (,) (liftE PEDProdLeft (deconstruct patl al))+ (liftE PEDProdRight (deconstruct patr ar))+deconstruct (PLeft patl) (Left al) = liftE PEDEitherLeft (deconstruct patl al)+deconstruct pat@(PLeft _) a = throwError PEDEitherMismatch+deconstruct (PRight patr) (Right ar) = liftE PEDEitherRight (deconstruct patr ar)+deconstruct pat@(PRight _) a = throwError PEDEitherMismatch+deconstruct (PIn pat) a = liftE PEDIn (deconstruct pat (out a))++construct :: Pat a env con -> env -> a+construct PVar (Var a) = a+construct PVar' (Var a) = a+construct (PConst c) _ = c+construct (PProd patl patr) (al, ar) = (construct patl al, construct patr ar)+construct (PLeft patl) al = Left (construct patl al)+construct (PRight patr) ar = Right (construct patr ar)+construct (PIn pat) a = inn (construct pat a)++fromContainerV :: Pat v env con -> con -> Either (PatExprDirError v) env+fromContainerV PVar Nothing = throwError PEDValueUnrecoverable+fromContainerV PVar (Just v) = return (Var v)+fromContainerV PVar' Nothing = throwError PEDValueUnrecoverable+fromContainerV PVar' (Just v) = return (Var v)+fromContainerV (PConst c) con = return ()+fromContainerV (PProd patl patr) (conl, conr) = liftM2 (,) (liftE PEDProdLeft (fromContainerV patl conl))+ (liftE PEDProdRight (fromContainerV patr conr))+fromContainerV (PLeft pat) con = liftE PEDEitherLeft (fromContainerV pat con)+fromContainerV (PRight pat) con = liftE PEDEitherRight (fromContainerV pat con)+fromContainerV (PIn pat) con = liftE PEDIn (fromContainerV pat con)++fromContainerS :: Pat s env con -> env -> con -> env+fromContainerS PVar (Var s) Nothing = (Var s)+fromContainerS PVar (Var s) (Just s') = (Var s')+fromContainerS PVar' (Var s) Nothing = (Var s)+fromContainerS PVar' (Var s) (Just s') = (Var s')+fromContainerS (PConst c) _ _ = ()+fromContainerS (PProd lpat rpat) (env, env') (con, con') = (fromContainerS lpat env con, fromContainerS rpat env' con')+fromContainerS (PLeft pat) env con = fromContainerS pat env con+fromContainerS (PRight pat) env con = fromContainerS pat env con+fromContainerS (PIn pat) env con = fromContainerS pat env con++emptyContainer :: Pat v env con -> con+emptyContainer PVar = Nothing+emptyContainer PVar' = Nothing+emptyContainer (PConst c) = ()+emptyContainer (PProd rpatl rpatr) = (emptyContainer rpatl, emptyContainer rpatr)+emptyContainer (PLeft pat ) = emptyContainer pat+emptyContainer (PRight pat ) = emptyContainer pat+emptyContainer (PIn pat ) = emptyContainer pat++-- You need to explicitly specify the type arguments at the type level when using the Direction type.+-- From type, you could know the type of the data you want.+-- !comment: DMaybe did not used.+data Direction :: * -> * -> * where+ DVar :: Direction (Var a) a+ DLeft :: Direction a t -> Direction (a, b) t+ DRight :: Direction b t -> Direction (a, b) t++instance Show (Direction a t) where+ show DVar = "DVar"+ show (DLeft dir) = "(DLeft " ++ show dir ++ ")"+ show (DRight dir) = "(DRight " ++ show dir ++ ")"++retrieve :: Direction a t -> a -> t+retrieve DVar (Var x) = x+retrieve (DLeft p) (x, y) = retrieve p x+retrieve (DRight p) (x, y) = retrieve p y++data Expr :: * -> * -> * where+ EDir :: Direction orig a -> Expr orig a+ EConst :: Eq a => a -> Expr orig a+ EIn :: InOut a => Expr orig (F a) -> Expr orig a+ EProd :: Expr orig a -> Expr orig b -> Expr orig (a, b)+ ELeft :: Expr orig a -> Expr orig (Either a b)+ ERight :: Expr orig b -> Expr orig (Either a b)++instance Show (Expr orig a) where+ show (EDir dir) = "(EDir " ++ show dir ++ ")"+ show (EConst c) = "EConst"+ show (EProd e1 e2) = "(EProd " ++ show e1 ++ " " ++ show e2 ++ ")"+ show (ELeft e) = "(ELeft " ++ show e ++ ")"+ show (ERight e) = "(ERight " ++ show e ++ ")"+ show (EIn e) = "(EIn " ++ show e ++ ")"++eval :: Expr env a' -> env -> a'+eval (EDir dir) env = retrieve dir env+eval (EConst c) env = c+eval (EIn expr) env = inn (eval expr env)+eval (EProd exprl exprr) env = (eval exprl env, eval exprr env)+eval (ELeft expr ) env = Left $ eval expr env+eval (ERight expr ) env = Right $ eval expr env++-- The goal is to update the "Maybe" con to fill in proper values.+-- con follow the structure of Pat+-- we have updated value a', which follows the structure of Expr+uneval :: Pat a env con -> Expr env a' -> a' -> con -> Either (PatExprDirError a') con+uneval pat (EDir dir) a' con = unevalDir pat dir a' con+uneval pat (EConst c) a' con = if c == a' then return con else throwError PEDConstantMismatch+uneval pat (EIn expr) a' con = liftE PEDIn (uneval pat expr (out a') con)+uneval pat (EProd exprl exprr) (al', ar') con = liftE PEDProdLeft (uneval pat exprl al' con) >>= liftE PEDProdRight . uneval pat exprr ar'+uneval pat (ELeft expr) (Left al') con = liftE PEDEitherLeft (uneval pat expr al' con)+uneval pat expr@(ELeft _) a' con = throwError PEDEitherMismatch+uneval pat (ERight expr) (Right ar') con = liftE PEDEitherRight (uneval pat expr ar' con)+uneval pat expr@(ERight _) a' con = throwError PEDEitherMismatch++unevalDir :: Pat a env con -> Direction env a' -> a' -> con -> Either (PatExprDirError a') con+unevalDir PVar DVar a' (Just a'') = if a' == a''+ then return (Just a')+ else throwError (PEDIncompatibleUpdates a' a'')+unevalDir PVar DVar a' Nothing = return (Just a')+unevalDir PVar' DVar a' (Just a'') = throwError (PEDMultipleUpdates a' a'')+unevalDir PVar' DVar a' Nothing = return (Just a')+unevalDir (PConst c) _ a' con = return con+unevalDir (PProd patl patr) (DLeft dir) a' (conl, conr) = liftM (, conr) (unevalDir patl dir a' conl)+unevalDir (PProd patl patr) (DRight dir) a' (conl, conr) = liftM (conl ,) (unevalDir patr dir a' conr)+unevalDir (PLeft patl ) dir a' con = unevalDir patl dir a' con+unevalDir (PRight patr ) dir a' con = unevalDir patr dir a' con+unevalDir (PIn pat ) dir a' con = unevalDir pat dir a' con++-- TODO: static check of full embedding+-- checkFullEmbed :: BiGUL m s v -> Bool+-- checkFullEmbed Fail = True+-- checkFullEmbed Skip = True+-- checkFullEmbed Replace = True+-- checkFullEmbed (RearrS pat expr bigul) = checkFullEmbed bigul+-- checkFullEmbed (RearrV pat expr bigul) = checkRearr expr pat && checkFullEmbed bigul+-- checkFullEmbed (Dep bigul f) = checkFullEmbed bigul+-- checkFullEmbed (Case branches) = and (map checkBranch branches)++-- checkBranch :: (s -> v -> Bool, CaseBranch m s v) -> Bool+-- checkBranch (cond, Normal bigul _) = checkFullEmbed bigul+-- checkBranch (cond, _) = True++-- checkRearr :: Expr env v' -> Pat v env con -> Bool+-- checkRearr expr pat = checkCon pat (abstractUpdateCon expr pat (emptyContainer pat))++-- abstractUpdateCon :: Expr env a' -> Pat a env con -> con -> con+-- abstractUpdateCon (EDir dir) pat con = abstractUpdateDir pat dir con+-- abstractUpdateCon (EConst c) pat con = con+-- abstractUpdateCon (EIn expr) pat con = abstractUpdateCon expr pat con+-- abstractUpdateCon (EProd exprl exprr) pat con = abstractUpdateCon exprr pat (abstractUpdateCon exprl pat con)+-- abstractUpdateCon (ELeft expr) pat con = abstractUpdateCon expr pat con+-- abstractUpdateCon (ERight expr) pat con = abstractUpdateCon expr pat con++-- abstractUpdateDir :: Pat a env con -> Direction env a' -> con -> con+-- abstractUpdateDir PVar DVar Nothing = Just undefined+-- abstractUpdateDir PVar DVar (Just _) = Just undefined+-- abstractUpdateDir (PConst c) _ con = con+-- abstractUpdateDir (PProd patl patr) (DLeft dir) (conl, conr) = (abstractUpdateDir patl dir conl, conr)+-- abstractUpdateDir (PProd patl patr) (DRight dir) (conl, conr) = (conl, abstractUpdateDir patr dir conr)+-- abstractUpdateDir (PLeft patl ) dir con = abstractUpdateDir patl dir con+-- abstractUpdateDir (PRight patr ) dir con = abstractUpdateDir patr dir con+-- abstractUpdateDir (PIn pat ) dir con = abstractUpdateDir pat dir con++-- checkCon :: Pat v env con -> con -> Bool+-- checkCon PVar (Just _) = True+-- checkCon PVar Nothing = False+-- checkCon (PConst c) _ = True+-- checkCon (PProd patl patr) (conl, conr) = checkCon patl conl && checkCon patr conr+-- checkCon (PLeft patl) con = checkCon patl con+-- checkCon (PRight patr) con = checkCon patr con+-- checkCon (PIn pat ) con = checkCon pat con
+ src/Generics/BiGUL/Error.hs view
@@ -0,0 +1,191 @@+module Generics.BiGUL.Error where++import GHC.InOut+import Text.PrettyPrint+++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++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++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++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 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++liftE :: (a -> b) -> Either a c -> Either b c+liftE f = either (Left . f) Right
+ src/Generics/BiGUL/Interpreter.hs view
@@ -0,0 +1,109 @@+module Generics.BiGUL.Interpreter (put, get, PutResult, GetResult, errorTrace) where++import Generics.BiGUL.Error+import Generics.BiGUL.AST+import Control.Monad.Except+import Text.PrettyPrint+++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++type PutResult s v = Either (PutError s v) s++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')++getCaseBranch :: (s -> v -> Bool, CaseBranch s v) -> s -> GetResult s v+getCaseBranch (p , Normal bigul q) s =+ if q s+ then do v <- get bigul s+ if p s v+ then return v+ else throwError GPostVerificationFailed+ else throwError GBranchUnmatched+getCaseBranch (p , Adaptive f) s = throwError GAdaptiveBranchMatched++putCaseCheckDiversion :: [(s -> v -> Bool, CaseBranch s v)] -> s -> v -> Either (PutError s v) ()+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++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+putCaseWithAdaptation (pb@(p, b):bs) bs' s v cont =+ if p s v+ then liftE (PBranch 0) $+ case b of+ Normal bigul q -> do+ s' <- put bigul s v+ if p s' v+ then if q s'+ then putCaseCheckDiversion bs' s' v >> return s'+ else throwError PBranchPredictionIncorrect+ else throwError PPostVerificationFailed+ Adaptive f -> cont (f s v)+ else liftE incrBranchNo (putCaseWithAdaptation bs (pb:bs') s v cont)++putCase :: [(s -> v -> Bool, CaseBranch s v)] -> s -> v -> Either (PutError s v) s+putCase bs s v = putCaseWithAdaptation bs [] s v+ (\s' -> putCaseWithAdaptation bs [] s' v+ (const (throwError PAdaptiveBranchRevisited)))++type GetResult s v = Either (GetError s v) v++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)++getCase :: [(s -> v -> Bool, CaseBranch s v)] -> s -> GetResult s v+getCase [] s = throwError (GCaseExhausted [])+getCase (pb@(p, b):bs) s =+ catchBind (getCaseBranch pb s) return+ (\e -> do v <- liftE (addCurrentBranchError e) (getCase bs s)+ if not (p s v)+ then return v+ else throwError (GBranch 0 GPreviousBranchMatched))
+ src/Generics/BiGUL/Interpreter/Unsafe.hs view
@@ -0,0 +1,70 @@+module Generics.BiGUL.Interpreter.Unsafe (put, get) where++import Generics.BiGUL.AST+++fromRight :: Either a b -> b+fromRight (Right b) = b+fromRight _ = error "fromRight fails"++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'++getCaseBranch :: (s -> v -> Bool, CaseBranch s v) -> s -> Maybe v+getCaseBranch (p , Normal bigul q) s =+ if q s+ then let v = get bigul s+ in if p s v then Just v else Nothing+ else 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+ 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)++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++getCase :: [(s -> v -> Bool, CaseBranch s v)] -> s -> v+getCase (pb@(p, b):bs) s =+ case getCaseBranch pb s of+ Just v -> v+ Nothing -> getCase bs s
+ src/Generics/BiGUL/TH.hs view
@@ -0,0 +1,752 @@+module Generics.BiGUL.TH( normal, normal', normalS, normalV, normalV', normalSV, adaptive, adaptiveS, adaptiveV, adaptiveSV, update, deriveBiGULGeneric, rearrS, rearrV) where++import Data.Data+import Data.Maybe+import Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map+import Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as THS+import Language.Haskell.TH.Quote+import Generics.BiGUL.AST+import Control.Monad+++data ConTag = L | R+ deriving (Show, Data, Typeable)+++data PatTag = RTag -- ^ view pattern+ | STag -- ^ source Pattern+ | ETag -- ^ expression++instance Show PatTag where+ show ETag = "E"+ show _ = "P"++contag :: a -> a -> ConTag -> a+contag a1 _ L = a1+contag _ a2 R = a2+++class ConTagSeq a where+ toConTags :: a -> Name -> [ConTag]+++type TypeConstructor = String+type ValueConstructor = 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)++-- Find the Type Dec by Name+-- Construct an InstanceDec.+deriveBiGULGeneric :: Name -> Q [InstanceDec]+deriveBiGULGeneric name = do+ (name, typeVars, constructors) <-+ do+ 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."+ env <- consToEnv constructors+ let selectorsNameList = generateSelectorNames constructors+ let selectorDataDMaybeList = generateSelectorDataD 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) +++ [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 ]+ ]++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) 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++-- 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"+++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++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))) []+ 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+++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) ) []+ 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++-- construct selector names from constructors+generateSelectorNames :: [Con] -> [[Maybe Name]]+generateSelectorNames = map (\con ->+ case con of {+ RecC _ sts -> map (\(n, _, _) -> Just (mkName ( "Selector_" ++ nameBase n))) sts;+ _ -> []+ })++generateSelectorDataD :: [[Maybe Name]] -> [Maybe Dec]+generateSelectorDataD names = map (\name -> case name of {Just n -> Just $ DataD [] n [] [] []; Nothing -> Nothing}) (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' :: Name -> Name -> Name -> String -> Maybe Name -> Maybe Dec+generateSelectorDataType' nDataType vDataTypeName vModuleName moduleName (Just selectorName) =+ Just $ InstanceD []+ (AppT (ConT nDataType) (ConT selectorName))+ [FunD vDataTypeName ([Clause [WildP] (NormalB (LitE (StringL (show selectorName)))) []]),+ FunD vModuleName ([Clause [WildP] (NormalB (LitE (StringL moduleName))) []])+ ]+generateSelectorDataType' nDataType vDataTypeName vModuleName moduleName _ = Nothing++-- Selector Instance Declaration generation+generateSelectorInstanceDec :: Name -> Name -> ([Maybe Name], Con) -> [Maybe Dec]+generateSelectorInstanceDec nSelector vSelName ([] , _ ) = []+generateSelectorInstanceDec nSelector vSelName (names, (RecC _ sts)) = map (generateSelectorInstanceDec' nSelector vSelName) (zip names sts)++generateSelectorInstanceDec' :: Name -> Name -> (Maybe Name, THS.VarStrictType) -> Maybe Dec+generateSelectorInstanceDec' nSelector vSelName (Just selectorName, (name, _, _)) =+ Just $ InstanceD []+ (AppT (ConT nSelector) (ConT selectorName))+ [FunD vSelName ([Clause [WildP] (NormalB (LitE (StringL (nameBase name)))) []])]+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+generateTypeVarsType n [] = ConT n -- not polymorphic case.+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."+ }) tvars+++constructLRs :: Int -> [[ConTag]]+constructLRs 0 = []+constructLRs 1 = [[]]+constructLRs n = [L] : map (R:) (constructLRs (n-1))++lookupLRs :: Name -> Q [ConTag]+lookupLRs conName = do+ info <- reify conName+ datatypeName <-+ case info of+ DataConI _ _ n _ -> return n+ _ -> fail $ nameBase conName ++ " is not a data constructor"+ TyConI (DataD _ _ _ cons _) <- reify datatypeName+ return $ constructLRs (length cons) !!+ fromJust (List.findIndex (== conName) (map (\con -> case con of { NormalC n _ -> n; RecC n _ -> n}) cons))++lookupRecordLength :: Name -> Q Int+lookupRecordLength conName = do+ info <- reify conName+ datatypeName <-+ case info of+ DataConI _ _ n _ -> return n+ _ -> fail $ nameBase conName ++ " is not a data constructor"+ TyConI (DataD _ _ _ cons _) <- reify datatypeName+ return $ (\(RecC _ fs) -> length fs) (fromJust (List.find (\(RecC n _) -> n == conName) cons))++lookupRecordField :: Name -> Name -> Q Int+lookupRecordField conName fieldName = do+ info <- reify conName+ datatypeName <-+ case info of+ DataConI _ _ n _ -> return n+ _ -> fail $ nameBase conName ++ " is not a data constructor"+ TyConI (DataD _ _ _ cons _) <- reify datatypeName+ 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+++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."++-- |+mkPat :: TH.Pat -> PatTag -> [Name] -> Q TH.Exp++mkPat (LitP c) patTag _ = do+ (_, [gconst]) <- lookupNames [] [astNameSpace ++ show patTag ++ "Const"] (notFoundMsg $ 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")+ return $ ConE gconst `AppE` unitt+ else do+ lrs <- lookupLRs name+ conInEither <- mkConstrutorFromLRs lrs patTag+ pes <- case ps of+ [] -> mkPat (ConP name' []) patTag dupnames+ _ -> 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+ indexs <- mapM (\(n,_) -> lookupRecordField name n) ps -- positions of the fields mentioned in p+ let nps = map snd ps -- patterns for the fields+ mkPat (ConP name (helper 0 len (zip indexs nps) [])) patTag dupnames -- grab the pattern for position i for each 0 <= i < len from zip indexs nps+ where findInPair [] i = WildP+ findInPair ((j,p):xs) i | i == j = p+ | otherwise = findInPair xs i+ helper i n pairs acc | i == n = acc+ | 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"])+ return $ ConE gin `AppE` (ConE gright `AppE` (ConE gprod `AppE` hexp `AppE` rexp))++mkPat (InfixP pl name pr) patTag dupnames = do+ ConE name' <- [| (:) |]+ 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"])+ return $ ConE gin `AppE` (ConE gright `AppE` (ConE gprod `AppE` lpat `AppE` rpat))+ else fail $ "constructors mismatch: " ++ nameBase name ++ " and " ++ nameBase name'+++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")+ return ((ConE gprod `AppE` lexp) `AppE` rexp)++++mkPat (WildP) RTag _ = fail $ "Wildcard(_) connot be used in lambda pattern expression."+mkPat (WildP) STag _ = do+ (_, [pvar']) <- lookupNames [] [astNameSpace ++ "PVar'"] (notFoundMsg "PVar'")+ return $ ConE pvar'+++mkPat (VarP name) _ dupnames = do+ (_, [pvar,pvar']) <- lookupNames [] [ astNameSpace ++ s | s <- ["PVar", "PVar'"] ] (notFoundMsg "PVar,PVar'")+ return $ if name `elem` dupnames then ConE pvar else ConE pvar'++++mkPat _ patTag _ = fail $ "Pattern not handled yet."++++++++++-- | translate all (VarE name) to directions using env+rearrangeExp :: Exp -> Map String Exp -> Q Exp+rearrangeExp (VarE name) env =+ case Map.lookup (nameBase name) env of+ Just val -> return val+ Nothing -> fail $ "cannot find name " ++ nameBase name ++ " in env."+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"++++++++++mkEnvForRearr :: TH.Pat -> Q (Map String Exp)+mkEnvForRearr (LitP c) = return Map.empty++-- empty list is ok , mkEnvForRearr return Q Map.empty for it+mkEnvForRearr (ConP name ps) = mkEnvForRearr (TupP ps)++mkEnvForRearr (RecP name ps) = do+ len <- lookupRecordLength name+ indexs <- mapM (\(n,_) -> lookupRecordField name n) ps+ let nps = map snd ps+ mkEnvForRearr (ConP name (helper 0 len (zip indexs nps) []))+ where findInPair [] i = WildP+ findInPair ((j,p):xs) i | i == j = p+ | otherwise = findInPair xs i+ helper i n pairs acc | i == n = acc+ | otherwise = helper (i+1) n pairs (acc++[findInPair pairs i])++mkEnvForRearr (ListP []) = return Map.empty+mkEnvForRearr (ListP (pl:pr)) = do+ (_, [dleft,dright]) <- lookupNames [] [ astNameSpace ++ s | s <- ["DLeft", "DRight"] ] (notFoundMsg "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")+ lenv <- mkEnvForRearr pl+ renv <- mkEnvForRearr pr+ 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")+ subenvs <- mapM mkEnvForRearr ps+ let envs = zipWith (Map.map . foldr (.) id . map (AppE . ConE . contag dleft dright))+ (constructLRs (length ps)) subenvs+ return $ Map.unions envs++mkEnvForRearr WildP = return Map.empty++mkEnvForRearr (VarP name) = do+ (_, [dvar]) <- lookupNames [] [ astNameSpace ++ s | s <- ["DVar"] ] (notFoundMsg "DVar")+ return $ Map.singleton (nameBase name) (ConE dvar)++mkEnvForRearr _ = fail $ "Pattern not handled yet."++++++splitDataAndCon:: TH.Exp -> Q (TH.Exp -> TH.Exp ,[TH.Exp])++splitDataAndCon (AppE (ConE name) e2) = do+ lrs <- lookupLRs name+ con <- mkConstrutorFromLRs lrs ETag+ d <- mkBodyExpForRearr e2+ return (con,[d])++splitDataAndCon (AppE e1 e2) = do+ (c, ds) <- splitDataAndCon e1+ d <- mkBodyExpForRearr e2+ return (c,ds++[d])++splitDataAndCon _ = fail $ "Invalid data constructor in lambda body expression"++++mkBodyExpForRearr :: TH.Exp -> Q TH.Exp++mkBodyExpForRearr (LitE c) = do+ (_, [econst]) <- lookupNames [] [astNameSpace ++ "EConst"] (notFoundMsg "EConst")+ return $ ConE econst `AppE` (LitE c)++mkBodyExpForRearr (VarE name) = return $ VarE name++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")+ (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")+ if name == name'+ then return $ ConE econst `AppE` (ConE name)+ else mkBodyExpForRearr (AppE (ConE name) (ConE name'))++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")+ len <- lookupRecordLength name+ indexs <- mapM (\(n,_) -> lookupRecordField name n) es+ let nes = map snd es+ mkBodyExpForRearr (foldl (\acc e -> acc `AppE` e) (ConE name) (helper 0 len (zip indexs nes) [] (ConE name')))+ where findInPair [] i unit = unit+ findInPair ((j,p):xs) i unit | i == j = p+ | otherwise = findInPair xs i unit+ helper i n pairs acc unit | i == n = acc+ | otherwise = helper (i+1) n pairs (acc ++[(findInPair pairs i unit)]) unit++-- restrict infix op to : for now+mkBodyExpForRearr (InfixE (Just e1) (ConE name) (Just e2)) = do+ (ConE name') <- [| (:) |]+ 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")+ return $ ConE ein `AppE` (ConE eright `AppE` (ConE eprod `AppE` le `AppE` re))+ else fail $ "only (:) infix operator is allowed in lambda body expression"++mkBodyExpForRearr (ListE []) = do+ unitt <- [| () |]+ (_, [ein,eleft,econst]) <- lookupNames [] [astNameSpace ++ s | s <- ["EIn","ELeft","EConst"]] (notFoundMsg "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")+ 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")+ return ((ConE eprod `AppE` lexp) `AppE` rexp)+mkBodyExpForRearr _ = fail $ "Invalid syntax in lambda body 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)+ pat <- mkPat p patTag dupnames+ exp <- mkBodyExpForRearr e+ env <- mkEnvForRearr p+ newexp <- rearrangeExp exp (Map.map (ConE edir `AppE`) env)+ return ((ConE rearrc `AppE` pat) `AppE` newexp)++getAllVars :: TH.Exp -> [Name]+getAllVars (LitE c) = []+getAllVars (VarE name) = [name]+getAllVars (AppE e1 e2) = getAllVars e1 ++ getAllVars e2+getAllVars (ConE name) = []+getAllVars (RecConE name es) = concatMap getAllVars (map snd es)+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))++++++++mkExpFromPat :: TH.Pat -> Q TH.Exp+mkExpFromPat (LitP c) = return (LitE c)+mkExpFromPat (ConP name ps) = do+ es <- mapM mkExpFromPat ps+ return $ foldl (\acc e -> (AppE acc e)) (ConE name) es+mkExpFromPat (RecP name ps) = do+ rs <- mapM mkExpFromPat (map snd ps)+ let es = zip (map fst ps) rs+ return (RecConE name es)+mkExpFromPat (ListP ps) = do+ es <- mapM mkExpFromPat ps+ return (ListE es)+mkExpFromPat (InfixP pl name pr) = do+ epl <- mkExpFromPat pl+ epr <- mkExpFromPat pr+ return (InfixE (Just epl) (ConE name) (Just epr))+mkExpFromPat (TupP ps) = do+ es <- mapM mkExpFromPat ps+ return (TupE es)+mkExpFromPat (VarP name) = return (VarE name)+mkExpFromPat WildP = [| () |]+mkExpFromPat _ = fail $ "pattern not handled in mkExpFromPat"++mkExpFromPat' :: TH.Pat -> Q TH.Exp+mkExpFromPat' (ConP name ps ) = do (_, [replace]) <- lookupNames [] [astNameSpace ++ "Replace"] (notFoundMsg "Replace")+ ConP name' [] <- [p| () |]+ if name == name' && ps == []+ then return (ConE replace)+ else fail $ "rearrSV only supports tuple"+mkExpFromPat' (VarP name) = return (VarE name)+mkExpFromPat' (TupP ps) = do+ (_, [prod]) <- lookupNames [] [ astNameSpace ++ "Prod" ] (notFoundMsg "Prod")+ es <- mapM mkExpFromPat' ps+ return $ foldr1 (\e1 e2 -> ((ConE prod `AppE` e1) `AppE` e2)) es+mkExpFromPat' _ = fail $ "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")+ re2 <- toProduct e2+ re1 <- toProduct e1+ if e1 == (ConE eleft) || e1 == (ConE eright) || e1 == (ConE ein)+ then return re2+ 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++-- | takes a source pattern and produces a tuple pattern consisting of all the variables in the source pattern+-- 1:s:ss -> (() , (s, ss))+mkProdPatFromS :: TH.Pat -> Q TH.Pat+mkProdPatFromS (LitP c) = [p| () |]+mkProdPatFromS (ConP name ps) = do+ es <- mapM mkProdPatFromS ps+ mkProdPatFromSHelper $ TupP es+mkProdPatFromS (RecP name ps) = do+ rs <- mapM mkProdPatFromS (map snd ps)+ mkProdPatFromSHelper (TupP rs)+mkProdPatFromS (ListP ps) = do+ es <- mapM mkProdPatFromS ps+ mkProdPatFromSHelper (TupP es)+mkProdPatFromS (InfixP pl name pr) = do+ epl <- mkProdPatFromS pl+ epr <- mkProdPatFromS pr+ return (TupP [epl,epr])+mkProdPatFromS (TupP ps) = do+ es <- mapM mkProdPatFromS ps+ mkProdPatFromSHelper (TupP es)+mkProdPatFromS (VarP name) = return (VarP name)+mkProdPatFromS WildP = [p| () |]+mkProdPatFromS _ = fail $ "pattern not handled in mkProdPatFromS"++-- | 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")+ sp <- qsp+ vp <- qvp+ pp <- qpp+ pd <- qpd+ spat <- mkPat sp STag []+ vpat <- mkPat vp RTag []+ commonexp <- mkExpFromPat pp+ commonexp' <- mkBodyExpForRearr commonexp+ commonexp'' <- toProduct commonexp'+ senv <- mkEnvForRearr sp+ sbody <- rearrangeExp commonexp'' (Map.map (ConE edir `AppE`) senv)+ 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)+++update :: Q TH.Pat -> Q TH.Pat -> Q [TH.Dec] -> Q TH.Exp+update = \pv ps 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"++withPatTag :: PatTag -> String -> String+withPatTag tag con = show tag ++ con++concatWith :: String -> [String] -> String+concatWith sep [] = ""+concatWith sep (x:xs) = x ++ sep ++ concatWith sep xs+++class ExpOrPat a where+ toExp :: a -> TH.ExpQ++instance ExpOrPat (TH.ExpQ) 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) |]++-- $(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) |]+++nameAdaptive :: TH.ExpQ+nameAdaptive = lookupNames [] [astNameSpace ++ "Adaptive"] (notFoundMsg "Adaptive") >>= \(_, [badaptive]) -> conE badaptive++nameNormal :: TH.ExpQ+nameNormal = lookupNames [] [astNameSpace ++ "Normal"] (notFoundMsg "Normal") >>= \(_, [bnormal]) -> conE bnormal+