diff --git a/BiGUL.cabal b/BiGUL.cabal new file mode 100644 --- /dev/null +++ b/BiGUL.cabal @@ -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. . + +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 and Zirun Zhu +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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/UNLICENSE b/UNLICENSE new file mode 100644 --- /dev/null +++ b/UNLICENSE @@ -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 diff --git a/src/GHC/InOut.hs b/src/GHC/InOut.hs new file mode 100644 --- /dev/null +++ b/src/GHC/InOut.hs @@ -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 +-- 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) } + diff --git a/src/Generics/BiGUL/AST.hs b/src/Generics/BiGUL/AST.hs new file mode 100644 --- /dev/null +++ b/src/Generics/BiGUL/AST.hs @@ -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 " + +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 new file mode 100644 --- /dev/null +++ b/src/Generics/BiGUL/Error.hs @@ -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 diff --git a/src/Generics/BiGUL/Interpreter.hs b/src/Generics/BiGUL/Interpreter.hs new file mode 100644 --- /dev/null +++ b/src/Generics/BiGUL/Interpreter.hs @@ -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)) diff --git a/src/Generics/BiGUL/Interpreter/Unsafe.hs b/src/Generics/BiGUL/Interpreter/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Generics/BiGUL/Interpreter/Unsafe.hs @@ -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 diff --git a/src/Generics/BiGUL/TH.hs b/src/Generics/BiGUL/TH.hs new file mode 100644 --- /dev/null +++ b/src/Generics/BiGUL/TH.hs @@ -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 +