Removed PolyplateSpine in favour of using PolyplateM (and the State monad) everywhere
This commit is contained in:
Neil Brown
parent
04974ae470
commit
f2c4ada01b
10
Makefile.am
10
Makefile.am
|
|
@ -106,7 +106,7 @@ modulesdir=$(TOCKMODDIR)
|
|||
tockincdir=$(TOCKINCDIR)
|
||||
tocklibdir=$(TOCKLIBDIR)
|
||||
|
||||
config/Paths.hs: config/Paths.hs.in
|
||||
config/Paths.hs: config/Paths.hs.in Makefile
|
||||
@sed -e 's,@@pkgincludedir@@,$(pkgincludedir),g' config/Paths.hs.in \
|
||||
| sed -e 's,@@tockdir@@,$(TOCKDIR),g' \
|
||||
| sed -e 's,@@tockmoddir@@,$(TOCKMODDIR),g' \
|
||||
|
|
@ -114,10 +114,7 @@ config/Paths.hs: config/Paths.hs.in
|
|||
| sed -e 's,@@tocklibdir@@,$(TOCKLIBDIR),g' >config/Paths.hs
|
||||
|
||||
data/NavAST.hs: GenNavAST$(EXEEXT)
|
||||
./GenNavAST$(EXEEXT) data/NavAST.hs data/NavASTSpine.hs
|
||||
|
||||
data/NavASTSpine.hs: GenNavAST$(EXEEXT)
|
||||
./GenNavAST$(EXEEXT) data/NavAST.hs data/NavASTSpine.hs
|
||||
./GenNavAST$(EXEEXT) data/NavAST.hs
|
||||
|
||||
data/OrdAST.hs: GenOrdAST$(EXEEXT)
|
||||
./GenOrdAST$(EXEEXT) > data/OrdAST.hs
|
||||
|
|
@ -130,7 +127,6 @@ config_sources += config/Paths.hs
|
|||
config_sources += config/TypeSizes.hs
|
||||
|
||||
BUILT_SOURCES = data/NavAST.hs
|
||||
BUILT_SOURCES += data/NavASTSpine.hs
|
||||
BUILT_SOURCES += data/OrdAST.hs
|
||||
BUILT_SOURCES += data/TagAST.hs
|
||||
BUILT_SOURCES += frontends/LexOccam.hs
|
||||
|
|
@ -233,7 +229,7 @@ tocktest_SOURCES += transformations/PassTest.hs
|
|||
tocktest_SOURCES += transformations/SimplifyAbbrevsTest.hs
|
||||
tocktest_SOURCES += transformations/SimplifyTypesTest.hs
|
||||
|
||||
pregen_sources = data/AST.hs data/CompState.hs
|
||||
pregen_sources = data/AST.hs data/CompState.hs config/Paths.hs
|
||||
pregen_sources += pregen/PregenUtils.hs
|
||||
pregen_sources += polyplate/Data/Generics/Polyplate/GenInstances.hs
|
||||
|
||||
|
|
|
|||
|
|
@ -182,11 +182,11 @@ cgenTopLevel headerName s
|
|||
= A.nameName n `elem` (csOriginalTopLevelProcs cs)
|
||||
|
||||
tellToHeader $ sequence_ $ map (call genForwardDeclaration)
|
||||
(listifyDepth isTopLevelSpec s)
|
||||
(listifyTopDown isTopLevelSpec s)
|
||||
-- Things like lifted wrapper_procs we still need to forward-declare,
|
||||
-- but we do it in the C file, not in the header:
|
||||
sequence_ $ map (call genForwardDeclaration)
|
||||
(listifyDepth (not . isTopLevelSpec) s)
|
||||
(listifyTopDown (not . isTopLevelSpec) s)
|
||||
|
||||
tell ["#include \"", dropPath headerName, "\"\n"]
|
||||
|
||||
|
|
|
|||
|
|
@ -144,11 +144,11 @@ cppgenTopLevel headerName s
|
|||
= A.nameName n `elem` (csOriginalTopLevelProcs cs)
|
||||
|
||||
tellToHeader $ sequence_ $ map (call genForwardDeclaration)
|
||||
(listifyDepth isTopLevelSpec s)
|
||||
(listifyTopDown isTopLevelSpec s)
|
||||
-- Things like lifted wrapper_procs we still need to forward-declare,
|
||||
-- but we do it in the C file, not in the header:
|
||||
sequence_ $ map (call genForwardDeclaration)
|
||||
(listifyDepth (\sp@(A.Specification _ n _)
|
||||
(listifyTopDown (\sp@(A.Specification _ n _)
|
||||
-> not (isTopLevelSpec sp)
|
||||
&& A.nameName n `notElem` map fst (csExternals cs)) s)
|
||||
|
||||
|
|
|
|||
|
|
@ -107,12 +107,12 @@ followBK = map followBK'
|
|||
next = Set.fromList $ map Var $ concatMap allVarsInBK bk
|
||||
|
||||
allVarsInBK :: BackgroundKnowledge -> [A.Variable]
|
||||
allVarsInBK (Equal a b) = listifyDepth (const True) a
|
||||
++ listifyDepth (const True) b
|
||||
allVarsInBK (LessThanOrEqual a b) = listifyDepth (const True) a
|
||||
++ listifyDepth (const True) b
|
||||
allVarsInBK (RepBoundsIncl v a b) = v : (listifyDepth (const True) a
|
||||
++ listifyDepth (const True) b)
|
||||
allVarsInBK (Equal a b) = listifyTopDown (const True) a
|
||||
++ listifyTopDown (const True) b
|
||||
allVarsInBK (LessThanOrEqual a b) = listifyTopDown (const True) a
|
||||
++ listifyTopDown (const True) b
|
||||
allVarsInBK (RepBoundsIncl v a b) = v : (listifyTopDown (const True) a
|
||||
++ listifyTopDown (const True) b)
|
||||
|
||||
data And a = And [a]
|
||||
data Or a = Or [a]
|
||||
|
|
|
|||
|
|
@ -204,7 +204,7 @@ findConstraints graph startNode
|
|||
processNode (n, e) nodeVal curAgg = case fmap getNodeData $ lab graph n of
|
||||
Just u ->
|
||||
let overlapsWithWritten e = not $ null $ intersect
|
||||
(listifyDepth (const True) $ snd e)
|
||||
(listifyTopDown (const True) $ snd e)
|
||||
[v | Var v <- Map.keys $ writtenVars $ nodeVars u]
|
||||
valFilt = filter (not . overlapsWithWritten) $
|
||||
nub $ nodeVal ++ (case e of
|
||||
|
|
|
|||
|
|
@ -1307,10 +1307,14 @@ inferTypes = occamOnlyPass "Infer types"
|
|||
-- This is actually a series of smaller passes that check particular types
|
||||
-- inside the AST, but it doesn't really make sense to split it up.
|
||||
checkTypes ::
|
||||
(PolyplateSpine t (OneOpQ (PassM ()) A.Variable) () (PassM ())
|
||||
,PolyplateSpine t (OneOpQ (PassM ()) A.Expression) () (PassM ())
|
||||
,PolyplateSpine t (OneOpQ (PassM ()) A.SpecType) () (PassM ())
|
||||
,PolyplateSpine t (OneOpQ (PassM ()) A.Process) () (PassM ())
|
||||
(PolyplateM t (OneOpM PassM A.Variable) () PassM
|
||||
,PolyplateM t (OneOpM PassM A.Expression) () PassM
|
||||
,PolyplateM t (OneOpM PassM A.SpecType) () PassM
|
||||
,PolyplateM t (OneOpM PassM A.Process) () PassM
|
||||
,PolyplateM t () (OneOpM PassM A.Variable) PassM
|
||||
,PolyplateM t () (OneOpM PassM A.Expression) PassM
|
||||
,PolyplateM t () (OneOpM PassM A.SpecType) PassM
|
||||
,PolyplateM t () (OneOpM PassM A.Process) PassM
|
||||
) => Pass t
|
||||
checkTypes = occamOnlyPass "Check types"
|
||||
[Prop.inferredTypesRecorded, Prop.ambiguitiesResolved]
|
||||
|
|
@ -1326,8 +1330,8 @@ checkTypes = occamOnlyPass "Check types"
|
|||
|
||||
--{{{ checkVariables
|
||||
|
||||
checkVariables :: PlainCheckOn A.Variable
|
||||
checkVariables = checkDepthM doVariable
|
||||
checkVariables :: PassTypeOn A.Variable
|
||||
checkVariables x = checkDepthM doVariable x >> return x
|
||||
where
|
||||
doVariable :: Check A.Variable
|
||||
doVariable (A.SubscriptedVariable m s v)
|
||||
|
|
@ -1357,8 +1361,8 @@ checkVariables = checkDepthM doVariable
|
|||
--}}}
|
||||
--{{{ checkExpressions
|
||||
|
||||
checkExpressions :: PlainCheckOn A.Expression
|
||||
checkExpressions = checkDepthM doExpression
|
||||
checkExpressions :: PassTypeOn A.Expression
|
||||
checkExpressions x = checkDepthM doExpression x >> return x
|
||||
where
|
||||
doExpression :: Check A.Expression
|
||||
doExpression (A.MostPos m t) = checkNumeric m t
|
||||
|
|
@ -1409,8 +1413,8 @@ checkExpressions = checkDepthM doExpression
|
|||
--}}}
|
||||
--{{{ checkSpecTypes
|
||||
|
||||
checkSpecTypes :: PlainCheckOn A.SpecType
|
||||
checkSpecTypes = checkDepthM doSpecType
|
||||
checkSpecTypes :: PassTypeOn A.SpecType
|
||||
checkSpecTypes x = checkDepthM doSpecType x >> return x
|
||||
where
|
||||
doSpecType :: Check A.SpecType
|
||||
doSpecType (A.Place _ e) = checkExpressionInt e
|
||||
|
|
@ -1532,8 +1536,8 @@ checkSpecTypes = checkDepthM doSpecType
|
|||
--}}}
|
||||
--{{{ checkProcesses
|
||||
|
||||
checkProcesses :: PlainCheckOn A.Process
|
||||
checkProcesses = checkDepthM doProcess
|
||||
checkProcesses :: PassTypeOn A.Process
|
||||
checkProcesses x = checkDepthM doProcess x >> return x
|
||||
where
|
||||
doProcess :: Check A.Process
|
||||
doProcess (A.Assign m vs el)
|
||||
|
|
|
|||
|
|
@ -502,20 +502,28 @@ testOccamTypes = TestList
|
|||
--}}}
|
||||
]
|
||||
where
|
||||
testOK :: (PolyplateSpine a (OneOpQ (PassM ()) A.Variable) () (PassM ())
|
||||
,PolyplateSpine a (OneOpQ (PassM ()) A.Expression) () (PassM ())
|
||||
,PolyplateSpine a (OneOpQ (PassM ()) A.SpecType) () (PassM ())
|
||||
,PolyplateSpine a (OneOpQ (PassM ()) A.Process) () (PassM ())
|
||||
testOK :: (PolyplateM a (OneOpM PassM A.Variable) () PassM
|
||||
,PolyplateM a (OneOpM PassM A.Expression) () PassM
|
||||
,PolyplateM a (OneOpM PassM A.SpecType) () PassM
|
||||
,PolyplateM a (OneOpM PassM A.Process) () PassM
|
||||
,PolyplateM a () (OneOpM PassM A.Variable) PassM
|
||||
,PolyplateM a () (OneOpM PassM A.Expression) PassM
|
||||
,PolyplateM a () (OneOpM PassM A.SpecType) PassM
|
||||
,PolyplateM a () (OneOpM PassM A.Process) PassM
|
||||
,Show a, Data a) => Int -> a -> Test
|
||||
testOK n orig
|
||||
= TestCase $ testPass ("testOccamTypes " ++ show n)
|
||||
orig OccamTypes.checkTypes orig
|
||||
startState
|
||||
|
||||
testFail :: (PolyplateSpine a (OneOpQ (PassM ()) A.Variable) () (PassM ())
|
||||
,PolyplateSpine a (OneOpQ (PassM ()) A.Expression) () (PassM ())
|
||||
,PolyplateSpine a (OneOpQ (PassM ()) A.SpecType) () (PassM ())
|
||||
,PolyplateSpine a (OneOpQ (PassM ()) A.Process) () (PassM ())
|
||||
testFail :: (PolyplateM a (OneOpM PassM A.Variable) () PassM
|
||||
,PolyplateM a (OneOpM PassM A.Expression) () PassM
|
||||
,PolyplateM a (OneOpM PassM A.SpecType) () PassM
|
||||
,PolyplateM a (OneOpM PassM A.Process) () PassM
|
||||
,PolyplateM a () (OneOpM PassM A.Variable) PassM
|
||||
,PolyplateM a () (OneOpM PassM A.Expression) PassM
|
||||
,PolyplateM a () (OneOpM PassM A.SpecType) PassM
|
||||
,PolyplateM a () (OneOpM PassM A.Process) PassM
|
||||
,Show a, Data a) => Int -> a -> Test
|
||||
testFail n orig
|
||||
= TestCase $ testPassShouldFail ("testOccamTypes " ++ show n)
|
||||
|
|
|
|||
|
|
@ -61,11 +61,11 @@ type RainTypeM = StateT RainTypeState PassM
|
|||
|
||||
type RainTypePassType = forall t. t -> StateT RainTypeState PassM t
|
||||
|
||||
type RainTypeCheckOn a = forall t. PolyplateSpine t (OneOpQ (RainTypeM ()) a) ()
|
||||
(RainTypeM ()) => t -> RainTypeM ()
|
||||
type RainTypeCheckOn a = forall t. PolyplateM t (OneOpM RainTypeM a) () RainTypeM
|
||||
=> t -> RainTypeM ()
|
||||
|
||||
type RainTypeCheckOn2 a b = forall t.
|
||||
(PolyplateSpine t (TwoOpQ (RainTypeM ()) a b) () (RainTypeM ())
|
||||
(PolyplateM t (TwoOpM RainTypeM a b) () RainTypeM
|
||||
) => t -> RainTypeM ()
|
||||
|
||||
|
||||
|
|
@ -128,12 +128,12 @@ markUnify x y
|
|||
|
||||
performTypeUnification ::
|
||||
-- | A shorthand for prerequisites when you need to spell them out:
|
||||
(PolyplateSpine t (OneOpQ (RainTypeM ()) A.Specification) () (RainTypeM ())
|
||||
,PolyplateSpine t (OneOpQ (RainTypeM ()) A.Process) () (RainTypeM ())
|
||||
,PolyplateSpine t (OneOpQ (RainTypeM ()) A.Expression) () (RainTypeM ())
|
||||
,PolyplateSpine t (TwoOpQ (RainTypeM ()) A.Process A.Expression) () (RainTypeM ())
|
||||
,PolyplateSpine t (TwoOpQ (RainTypeM ()) A.Process A.Choice) () (RainTypeM ())
|
||||
,PolyplateSpine t (TwoOpQ (RainTypeM ()) A.Process A.Alternative) () (RainTypeM ())
|
||||
(PolyplateM t (OneOpM RainTypeM A.Specification) () RainTypeM
|
||||
,PolyplateM t (OneOpM RainTypeM A.Process) () RainTypeM
|
||||
,PolyplateM t (OneOpM RainTypeM A.Expression) () RainTypeM
|
||||
,PolyplateM t (TwoOpM RainTypeM A.Process A.Expression) () RainTypeM
|
||||
,PolyplateM t (TwoOpM RainTypeM A.Process A.Choice) () RainTypeM
|
||||
,PolyplateM t (TwoOpM RainTypeM A.Process A.Alternative) () RainTypeM
|
||||
,PolyplateM t () (OneOpM PassM A.Type) PassM
|
||||
,PolyplateM t (OneOpM PassM A.Type) () PassM
|
||||
) => Pass t
|
||||
|
|
|
|||
|
|
@ -61,12 +61,6 @@ type PassOnOpsM m ops
|
|||
|
||||
type PassOnOps ops = PassOnOpsM PassM ops
|
||||
|
||||
type CheckOnOps ops
|
||||
= (PolyplateSpine t ops () (PassM ())) => Pass t
|
||||
|
||||
type PlainCheckOnOps ops
|
||||
= (PolyplateSpine t ops () (PassM ())) => t -> PassM ()
|
||||
|
||||
type PassASTOnOps ops
|
||||
= (PolyplateM A.AST ops () PassM, PolyplateM A.AST () ops PassM) => Pass A.AST
|
||||
|
||||
|
|
@ -76,8 +70,6 @@ type PassTypeOnOps ops
|
|||
type PassOn t = PassOnOps (OneOpM PassM t)
|
||||
type PassOn2 s t = PassOnOps (TwoOpM PassM s t)
|
||||
type PassTypeOn t = PassTypeOnOps (OneOpM PassM t)
|
||||
type CheckOn t = CheckOnOps (OneOpQ (PassM ()) t)
|
||||
type PlainCheckOn t = PlainCheckOnOps (OneOpQ (PassM ()) t)
|
||||
|
||||
-- | A description of an AST-mangling pass.
|
||||
data Pass t = Pass {
|
||||
|
|
|
|||
|
|
@ -22,7 +22,6 @@ module Traversal (
|
|||
TransformM, Transform, TransformStructured, TransformStructured', TransformStructuredM'
|
||||
, CheckM, Check
|
||||
, ExtOpMP, ExtOpMS, ExtOpMSP, extOpMS, PassOnStruct, PassASTOnStruct
|
||||
, ExtOpQS, extOpQS
|
||||
, applyBottomUpMS, ASTStructured
|
||||
, module Data.Generics.Polyplate
|
||||
, module Data.Generics.Polyplate.Schemes
|
||||
|
|
@ -36,7 +35,6 @@ import Data.Generics.Polyplate.Schemes
|
|||
|
||||
import qualified AST as A
|
||||
import NavAST()
|
||||
import NavASTSpine()
|
||||
import Pass
|
||||
|
||||
-- | A transformation for a single 'Data' type.
|
||||
|
|
@ -71,52 +69,36 @@ type PassASTOnStruct = PassASTOnOps (ExtOpMSP BaseOp)
|
|||
|
||||
class (PolyplateM (A.Structured a) () opsM m
|
||||
,PolyplateM (A.Structured a) opsM () m
|
||||
,PolyplateSpine (A.Structured a) opsQ () r
|
||||
,PolyplateSpine (A.Structured a) () opsQ r
|
||||
,Data a
|
||||
,Monad m
|
||||
) => ASTStructured a opsM m opsQ r
|
||||
|
||||
instance (PolyplateM (A.Structured ()) () opsM m
|
||||
,PolyplateM (A.Structured ()) opsM () m
|
||||
,PolyplateSpine (A.Structured ()) opsQ () r
|
||||
,PolyplateSpine (A.Structured ()) () opsQ r
|
||||
,Monad m) => ASTStructured () opsM m opsQ r
|
||||
|
||||
instance (PolyplateM (A.Structured A.Alternative) () opsM m
|
||||
,PolyplateM (A.Structured A.Alternative) opsM () m
|
||||
,PolyplateSpine (A.Structured A.Alternative) opsQ () r
|
||||
,PolyplateSpine (A.Structured A.Alternative) () opsQ r
|
||||
,Monad m) => ASTStructured A.Alternative opsM m opsQ r
|
||||
|
||||
instance (PolyplateM (A.Structured A.Choice) () opsM m
|
||||
,PolyplateM (A.Structured A.Choice) opsM () m
|
||||
,PolyplateSpine (A.Structured A.Choice) opsQ () r
|
||||
,PolyplateSpine (A.Structured A.Choice) () opsQ r
|
||||
,Monad m) => ASTStructured A.Choice opsM m opsQ r
|
||||
|
||||
instance (PolyplateM (A.Structured A.ExpressionList) () opsM m
|
||||
,PolyplateM (A.Structured A.ExpressionList) opsM () m
|
||||
,PolyplateSpine (A.Structured A.ExpressionList) opsQ () r
|
||||
,PolyplateSpine (A.Structured A.ExpressionList) () opsQ r
|
||||
,Monad m) => ASTStructured A.ExpressionList opsM m opsQ r
|
||||
|
||||
instance (PolyplateM (A.Structured A.Option) () opsM m
|
||||
,PolyplateM (A.Structured A.Option) opsM () m
|
||||
,PolyplateSpine (A.Structured A.Option) opsQ () r
|
||||
,PolyplateSpine (A.Structured A.Option) () opsQ r
|
||||
,Monad m) => ASTStructured A.Option opsM m opsQ r
|
||||
|
||||
instance (PolyplateM (A.Structured A.Process) () opsM m
|
||||
,PolyplateM (A.Structured A.Process) opsM () m
|
||||
,PolyplateSpine (A.Structured A.Process) opsQ () r
|
||||
,PolyplateSpine (A.Structured A.Process) () opsQ r
|
||||
,Monad m) => ASTStructured A.Process opsM m opsQ r
|
||||
|
||||
instance (PolyplateM (A.Structured A.Variant) () opsM m
|
||||
,PolyplateM (A.Structured A.Variant) opsM () m
|
||||
,PolyplateSpine (A.Structured A.Variant) opsQ () r
|
||||
,PolyplateSpine (A.Structured A.Variant) () opsQ r
|
||||
,Monad m) => ASTStructured A.Variant opsM m opsQ r
|
||||
|
||||
|
||||
|
|
@ -150,47 +132,6 @@ extOpMS ops (_, f)
|
|||
`extOpM` (f :: A.Structured A.Alternative -> m (A.Structured A.Alternative))
|
||||
`extOpM` (f :: A.Structured () -> m (A.Structured ()))
|
||||
|
||||
type ExtOpQS r opT =
|
||||
(A.Structured () -> r,
|
||||
(A.Structured A.Alternative -> r,
|
||||
(A.Structured A.Choice -> r,
|
||||
(A.Structured A.ExpressionList -> r,
|
||||
(A.Structured A.Option -> r,
|
||||
(A.Structured A.Process -> r,
|
||||
(A.Structured A.Variant -> r,
|
||||
opT)))))))
|
||||
|
||||
extOpQS :: forall m opT op0T r.
|
||||
(PolyplateSpine (A.Structured ()) () op0T r,
|
||||
PolyplateSpine (A.Structured A.Alternative) () op0T r,
|
||||
PolyplateSpine (A.Structured A.Choice) () op0T r,
|
||||
PolyplateSpine (A.Structured A.ExpressionList) () op0T r,
|
||||
PolyplateSpine (A.Structured A.Option) () op0T r,
|
||||
PolyplateSpine (A.Structured A.Process) () op0T r,
|
||||
PolyplateSpine (A.Structured A.Variant) () op0T r,
|
||||
PolyplateSpine (A.Structured ()) op0T () r,
|
||||
PolyplateSpine (A.Structured A.Alternative) op0T () r,
|
||||
PolyplateSpine (A.Structured A.Choice) op0T () r,
|
||||
PolyplateSpine (A.Structured A.ExpressionList) op0T () r,
|
||||
PolyplateSpine (A.Structured A.Option) op0T () r,
|
||||
PolyplateSpine (A.Structured A.Process) op0T () r,
|
||||
PolyplateSpine (A.Structured A.Variant) op0T () r) =>
|
||||
opT ->
|
||||
-- Pairing the next two arguments allows us to apply this function infix:
|
||||
(op0T, -- just a type witness
|
||||
forall t. ASTStructured t () PassM op0T r => A.Structured t -> r) ->
|
||||
ExtOpQS r opT
|
||||
extOpQS ops (_, f)
|
||||
= ops
|
||||
`extOpQ` (f :: A.Structured A.Variant -> r)
|
||||
`extOpQ` (f :: A.Structured A.Process -> r)
|
||||
`extOpQ` (f :: A.Structured A.Option -> r)
|
||||
`extOpQ` (f :: A.Structured A.ExpressionList -> r)
|
||||
`extOpQ` (f :: A.Structured A.Choice -> r)
|
||||
`extOpQ` (f :: A.Structured A.Alternative -> r)
|
||||
`extOpQ` (f :: A.Structured () -> r)
|
||||
|
||||
|
||||
applyBottomUpMS :: (PolyplateM t (ExtOpMSP BaseOp) () PassM) =>
|
||||
(forall a. (Data a, PolyplateM (A.Structured a) () (ExtOpMSP BaseOp) PassM) =>
|
||||
(A.Structured a -> PassM (A.Structured a)))
|
||||
|
|
|
|||
|
|
@ -124,14 +124,13 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
|
|||
--
|
||||
-- TODO include an example with routes
|
||||
module Data.Generics.Polyplate (PolyplateMRoute(..), PolyplateM(..), Polyplate(..),
|
||||
PolyplateSpine(..), {-FullSpine(..),-} transformSpine, {-transformSpineFull,-} trimTree,
|
||||
makeRecurseM, RecurseM, makeRecurse, Recurse,
|
||||
makeDescendM, DescendM, makeDescend, Descend,
|
||||
-- makeRecurseQ, RecurseQ,
|
||||
-- makeDescendQ, DescendQ,
|
||||
BaseOp, baseOp,
|
||||
ExtOpM, extOpM, ExtOpMRoute, extOpMRoute, ExtOp, extOp, OneOpM, OneOp, TwoOpM, TwoOp,
|
||||
ExtOpQ, extOpQ, OneOpQ, TwoOpQ) where
|
||||
ExtOpM, extOpM, ExtOpMRoute, extOpMRoute, ExtOp, extOp, OneOpM, OneOp, TwoOpM, TwoOp
|
||||
) where
|
||||
|
||||
import Control.Monad.Identity
|
||||
import Data.Maybe
|
||||
|
|
@ -232,77 +231,6 @@ instance (Monad m
|
|||
fakeRoute :: t -> Route t ()
|
||||
fakeRoute = const $ error "transformM"
|
||||
|
||||
-- List of use cases for the Polyplate type-class, to try to decide best on its
|
||||
-- necessary functions:
|
||||
--
|
||||
-- 1. To perform a monadic modification on specific types in the ops across a
|
||||
-- whole structure.
|
||||
-- 2. As #1, but non-monadic (use Identity monad to adapt the above)
|
||||
-- 3. To perform a query across the whole tree that returns a rose-tree that reflects
|
||||
-- the (spine-view) structure of the data.
|
||||
-- 4. As #3, but to return a flattened list (use flatten to adapt the above)
|
||||
-- 5. To perform a monadic modification that also uses modification wrappers,
|
||||
-- (a more general case of #1)
|
||||
--
|
||||
-- So I think there are two classes needed:
|
||||
--
|
||||
-- 1. One to apply monadic transformations that takes routes (covers #5, #2, #1)
|
||||
--
|
||||
-- 2. One to apply tree-based queries that transform a whole data structure into
|
||||
-- its tree spine-view, with optional methods for flattening into a depth-first
|
||||
-- or breadth-first order.
|
||||
|
||||
-- | A class for transforming a data structure into its spine-view rose tree based
|
||||
-- on query functions.
|
||||
--
|
||||
-- The first parameter is the item being processed. The fourth parameter is the
|
||||
-- return type of the query functions, which is used in the returned tree.
|
||||
--
|
||||
-- The second and third parameters are the usual ops sets, but of the form:
|
||||
--
|
||||
-- > (s -> a, (t -> a, ()))
|
||||
class PolyplateSpine t o o' a where
|
||||
-- | You are unlikely to need to use this function directly at all. See 'transformSpine'
|
||||
-- or 'applyQuery' and 'listifyDepth' (and friends).
|
||||
--
|
||||
-- The third parameter, which transformSpine passes as Nothing, is the value
|
||||
-- to be used for the current node. Because this value is set somewhere in the
|
||||
-- middle of the ops set, not necessarily at the end, this must be passed along
|
||||
-- the sideways calls (while processing the first ops set).
|
||||
transformSpineSparse :: o -> o' -> Maybe a -> t -> Tree (Maybe a)
|
||||
|
||||
transformSpine :: PolyplateSpine t o o' a => o -> o' -> t -> Tree (Maybe a)
|
||||
transformSpine o o' = transformSpineSparse o o' Nothing
|
||||
|
||||
{-
|
||||
-- | Used at the type-level by this library to force a full traversal of a data
|
||||
-- structure. You are unlikely to need to use this directly.
|
||||
data FullSpine a = FullSpine a
|
||||
-- TODO make this work
|
||||
|
||||
transformSpineFull :: (ConvertSpineOpsToFull a o co, ConvertSpineOpsToFull a o' co',
|
||||
PolyplateSpine t co co' a) =>
|
||||
a -> o -> o' -> t -> Tree a
|
||||
transformSpineFull def o o' x
|
||||
= fmap fromJust' $
|
||||
transformSpineSparse
|
||||
(convertSpineOpsToFull def o)
|
||||
(convertSpineOpsToFull def o')
|
||||
Nothing x
|
||||
where
|
||||
fromJust' (Just x) = x
|
||||
fromJust' _ = error "transformSpineFull: internal error"
|
||||
-}
|
||||
|
||||
-- | A function for pruning rose trees of maybe values. All trees where the node
|
||||
-- value (and the node value of all its children) is Nothing are discarded (Nothing
|
||||
-- is returned).
|
||||
trimTree :: Tree (Maybe a) -> Maybe (Tree (Maybe a))
|
||||
trimTree tr | isNothing (rootLabel tr) && null trimmedChildren = Nothing
|
||||
| otherwise = Just (Node (rootLabel tr) trimmedChildren)
|
||||
where
|
||||
trimmedChildren = mapMaybe trimTree (subForest tr)
|
||||
|
||||
-- | A non-monadic equivalent of PolyplateM. All ops sets are of the form:
|
||||
--
|
||||
-- > (a -> a, (b -> b, ()))
|
||||
|
|
@ -383,11 +311,6 @@ type ExtOpMRoute m opT t outer = ((t, Route t outer) -> m t, opT)
|
|||
-- for use with the 'Polyplate' class.
|
||||
type ExtOp opT t = (t -> t, opT)
|
||||
|
||||
-- | The type that extends a query-ops set to be applied to the given type (t).
|
||||
-- Not to be mixed with modification operations. This is for use with the 'PolyplateSpine'
|
||||
-- class.
|
||||
type ExtOpQ a opQ t = (t -> a, opQ)
|
||||
|
||||
-- | The function that extends an ops set (opT) in the given monad (m) to be applied to
|
||||
-- the given type (t). You cannot mix monadic and non-monadic operations in the
|
||||
-- same list. This is for use with the 'PolyplateM' class.
|
||||
|
|
@ -406,26 +329,15 @@ extOpMRoute ops f = (f, ops)
|
|||
extOp :: opT -> (t -> t) -> ExtOp opT t
|
||||
extOp ops f = (f, ops)
|
||||
|
||||
-- | The function that extends a query-ops set to be applied to the given type (t).
|
||||
-- Not to be mixed with modification operations. This is for use with the 'PolyplateSpine'
|
||||
-- class.
|
||||
extOpQ :: opQ -> (t -> a) -> ExtOpQ a opQ t
|
||||
extOpQ ops f = (f, ops)
|
||||
|
||||
|
||||
-- | A handy synonym for a monadic ops set with only one item, to use with 'PolyplateM'.
|
||||
type OneOpM m t = ExtOpM m BaseOp t
|
||||
-- | A handy synonym for an ops set with only one item, to use with 'Polyplate'.
|
||||
type OneOp t = ExtOp BaseOp t
|
||||
-- | A handy synonym for a query ops set with only one item, to use with 'PolyplateSpine'.
|
||||
type OneOpQ a t = ExtOpQ a BaseOp t
|
||||
|
||||
-- | A handy synonym for a monadic ops set with only two items, to use with 'PolyplateM'.
|
||||
type TwoOpM m s t = ExtOpM m (ExtOpM m BaseOp s) t
|
||||
-- | A handy synonym for an ops set with only two items, to use with 'Polyplate'.
|
||||
type TwoOp s t = ExtOp (ExtOp BaseOp s) t
|
||||
-- | A handy synonym for a monadic ops set with only two items, to use with 'PolyplateSpine'.
|
||||
type TwoOpQ a s t = ExtOpQ a (ExtOpQ a BaseOp s) t
|
||||
|
||||
|
||||
-- {{{ Various type-level programming ops conversions:
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
|
|||
module Data.Generics.Polyplate.GenInstances
|
||||
(GenOverlappedOption(..), GenClassOption(..),
|
||||
GenInstance, genInstance, genMapInstance, genSetInstance, genInstances,
|
||||
writeInstances, writeInstancesTo, writeInstancesToSep) where
|
||||
writeInstances, writeInstancesTo) where
|
||||
|
||||
import Control.Monad.State
|
||||
import Data.Char
|
||||
|
|
@ -440,231 +440,31 @@ instancesFrom genOverlapped genClass boxes w
|
|||
-- This is covered by one big overlapping instance:
|
||||
| otherwise = (False,[],[])
|
||||
|
||||
-- | Instances for a particular data type (i.e. where that data type is the
|
||||
-- first argument to 'Polyplate').
|
||||
spineInstancesFrom :: forall t. Data t => GenOverlappedOption -> GenClassOption -> [Witness] -> t -> IO [String]
|
||||
-- This method is similar to instancesFrom in terms of general behaviour, but still
|
||||
-- different enough that very little code could be shared, so it's clearer to pull
|
||||
-- it out to its own method:
|
||||
spineInstancesFrom genOverlapped genClass boxes w
|
||||
= do (specialProcessChildren, containedTypes) <-
|
||||
case find (== Plain (DataBox w)) boxes of
|
||||
Just (Detailed _ containedTypes _ doChildrenSpine) ->
|
||||
-- It's a special case, use the detailed info:
|
||||
do eachContained <- sequence [findTypesIn' c | DataBox c <- containedTypes]
|
||||
return (Just (containedTypes, doChildrenSpine), foldl Map.union Map.empty eachContained)
|
||||
-- It's a normal case, use findTypesIn' directly:
|
||||
_ -> do ts <- findTypesIn' w
|
||||
return (Nothing, ts)
|
||||
containedKeys <- liftM Set.fromList
|
||||
(sequence [typeKey c | DataBox c <- map witness $ justBoxes containedTypes])
|
||||
wKey <- typeKey w
|
||||
otherInsts <- sequence [do ck <- typeKey c
|
||||
return (otherInst wKey containedKeys c ck)
|
||||
| DataBox c <- map witness boxes]
|
||||
return $ baseInst specialProcessChildren ++ concat otherInsts
|
||||
where
|
||||
wName = show $ typeOf w
|
||||
wMunged = mungeName wName
|
||||
wDType = dataTypeOf w
|
||||
wCtrs = if isAlgType wDType then dataTypeConstrs wDType else []
|
||||
|
||||
-- The module prefix of this type, so we can use it in constructor names.
|
||||
modPrefix
|
||||
= if '.' `elem` (takeWhile (\c -> isAlphaNum c || c == '.') wName)
|
||||
then takeWhile (/= '.') wName ++ "."
|
||||
else ""
|
||||
|
||||
ctrArgs ctr
|
||||
= gmapQ DataBox (fromConstr ctr :: t)
|
||||
ctrArgTypes types
|
||||
= [show $ typeOf w | DataBox w <- types]
|
||||
|
||||
-- Given the context (a list of instance requirements), the left-hand ops,
|
||||
-- the right-hand ops, and a list of lines for the body of the class, generates
|
||||
-- an instance.
|
||||
--
|
||||
-- For GenOneClass this will be an instance of PolyplateM.
|
||||
--
|
||||
-- For GenClassPerType this will be an instance of PolyplateMFoo (or whatever)
|
||||
--
|
||||
-- For GenSlowDelegate this will be an instance of PolyplateM', with the first
|
||||
-- and last arguments swapped.
|
||||
genInst :: [String] -> String -> String -> [String] -> [String]
|
||||
genInst context ops0 ops1 body
|
||||
= ["instance (" ++ concat (intersperse ", " context) ++ ") =>"
|
||||
," " ++ contextSameType ops0 ops1 ++ " where"
|
||||
] ++ map (" " ++) body
|
||||
|
||||
-- Generates the name of an instance for the same type with the given two ops
|
||||
-- sets. The class name will be the same as genInst.
|
||||
contextSameType :: String -> String -> String
|
||||
contextSameType ops0 ops1 = case genClass of
|
||||
GenOneClass -> "PolyplateSpine (" ++ wName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " a"
|
||||
GenClassPerType -> "PolyplateSpine" ++ wMunged ++" " ++ ops0 ++ " " ++ ops1 ++ " a"
|
||||
GenSlowDelegate -> "PolyplateSpine' a " ++ ops0 ++ " " ++ ops1 ++ " (" ++ wName ++ ")"
|
||||
|
||||
-- Generates the name of an instance for a different type (for processing children).
|
||||
-- This will be PolyplateM or PolyplateM'.
|
||||
contextNewType :: String -> String -> String -> String
|
||||
contextNewType cName ops0 ops1 = case genClass of
|
||||
GenOneClass -> "PolyplateSpine (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " a"
|
||||
GenClassPerType -> "PolyplateSpine (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " a"
|
||||
GenSlowDelegate -> "PolyplateSpine' a " ++ ops0 ++ " " ++ ops1 ++ " (" ++ cName ++ ")"
|
||||
|
||||
|
||||
-- The function to define in the body, and also to use for processing the same
|
||||
-- type.
|
||||
funcSameType :: String
|
||||
funcSameType = case genClass of
|
||||
GenClassPerType -> "transformSpineSparse" ++ wMunged
|
||||
GenOneClass -> "transformSpineSparse"
|
||||
GenSlowDelegate -> "transformSpineSparse'"
|
||||
|
||||
-- The function to use for processing other types
|
||||
funcNewType :: String
|
||||
funcNewType = case genClass of
|
||||
GenClassPerType -> "transformSpineSparse"
|
||||
GenOneClass -> "transformSpineSparse"
|
||||
GenSlowDelegate -> "transformSpineSparse'"
|
||||
|
||||
-- | An instance that describes what to do when we have no transformations
|
||||
-- left to apply. You can pass it an override for the case of processing children
|
||||
-- (and the types that make up the children).
|
||||
baseInst :: Maybe ([DataBox], (String, String) -> [String]) -> [String]
|
||||
baseInst mdoChildren
|
||||
= concat
|
||||
[genInst context "()" "(f, ops)" $
|
||||
maybe
|
||||
(if isAlgType wDType
|
||||
-- An algebraic type: apply to each child if we're following.
|
||||
then (concatMap constrCase wCtrs)
|
||||
-- A primitive (or non-represented) type: just return it.
|
||||
else [funcSameType ++ " () _ _ _ = Node Nothing []"])
|
||||
(\(_,f) -> f (funcSameType, funcNewType)) mdoChildren
|
||||
,genInst [] "()" "()" [funcSameType ++ " () () q _ = Node q []"]
|
||||
--,genInst (contextNewType "(FullSpine a)" "()") "(FullSpine a)" "()" [funcSameType ++ " () () v = return v"]
|
||||
,if genOverlapped == GenWithoutOverlapped then [] else
|
||||
genInst
|
||||
[ contextSameType "r" "ops" ]
|
||||
"(b -> a, r)" "ops"
|
||||
[funcSameType ++ " (_, rest) ops = " ++ funcSameType ++ " rest ops"]
|
||||
,if genClass == GenClassPerType
|
||||
then ["class PolyplateSpine" ++ wMunged ++ " o o' a where"
|
||||
," " ++ funcSameType ++ " :: o -> o' -> Maybe a -> (" ++ wName ++
|
||||
") -> Tree (Maybe a)"
|
||||
,""
|
||||
,"instance (" ++ contextSameType "o0" "o1" ++ ") =>"
|
||||
," PolyplateSpine (" ++ wName ++ ") o0 o1 a where"
|
||||
," transformSpineSparse = " ++ funcSameType
|
||||
]
|
||||
else []
|
||||
]
|
||||
where
|
||||
-- | Class context for 'baseInst'.
|
||||
-- We need an instance of Polyplate for each of the types directly contained within
|
||||
-- this type, so we can recurse into them.
|
||||
context :: [String]
|
||||
context
|
||||
= [ contextNewType argType "(f,ops)" "()"
|
||||
| argType <- nub $ sort $ concatMap ctrArgTypes $
|
||||
maybe (map ctrArgs wCtrs) ((:[]) . fst) mdoChildren]
|
||||
|
||||
-- | A 'transformM' case for a particular constructor of this (algebraic)
|
||||
-- data type: pull the value apart, apply 'transformM' to each part of it,
|
||||
-- then stick it back together.
|
||||
constrCase :: Constr -> [String]
|
||||
constrCase ctr
|
||||
= [ funcSameType ++ " () " ++ (if argNums == [] then "_" else "ops") ++
|
||||
" q (" ++ ctrInput ++ ")"
|
||||
, " = Node q $ mapMaybe trimTree ["
|
||||
] ++
|
||||
intersperse
|
||||
" ,"
|
||||
[ " " ++ funcNewType ++ " ops () Nothing a" ++ show i
|
||||
| i <- argNums] ++
|
||||
[ " ]"
|
||||
]
|
||||
where
|
||||
argNums = [0 .. ((length $ ctrArgs ctr) - 1)]
|
||||
ctrS = show ctr
|
||||
ctrName = modPrefix ++ ctrS
|
||||
makeCtr vs = ctrName ++ concatMap (" " ++) vs
|
||||
ctrInput = makeCtr ["a" ++ show i | i <- argNums]
|
||||
ctrResult = makeCtr ["r" ++ show i | i <- argNums]
|
||||
|
||||
|
||||
-- | An instance that describes how to apply -- or not apply -- a
|
||||
-- transformation.
|
||||
otherInst :: Data s => Int -> Set.Set Int -> s -> Int -> [String]
|
||||
otherInst wKey containedKeys c cKey
|
||||
= if not shouldGen then [] else
|
||||
genInst context
|
||||
("((" ++ cName ++ ") -> a, r)")
|
||||
"ops"
|
||||
impl
|
||||
where
|
||||
cName = show $ typeOf c
|
||||
(shouldGen, context, impl)
|
||||
-- This type might contain the type that the transformation acts
|
||||
-- upon
|
||||
| cKey `Set.member` containedKeys
|
||||
= (True
|
||||
,[contextSameType "r" ("((" ++ cName ++ ") -> a, ops)")]
|
||||
,[if wKey == cKey
|
||||
then funcSameType ++ " (f, rest) ops _ v = "
|
||||
++ funcSameType ++ " rest (f, ops) (Just (f v)) v"
|
||||
else funcSameType ++ " (f, rest) ops = " ++ funcSameType ++ " rest (f, ops)"])
|
||||
-- This type can't contain the transformed type; just move on to the
|
||||
-- next transformation.
|
||||
| genOverlapped == GenWithoutOverlapped
|
||||
= (True
|
||||
,[contextSameType "r" "ops"]
|
||||
,[funcSameType ++ " (_, rest) ops = " ++ funcSameType ++ " rest ops"])
|
||||
-- This is covered by one big overlapping instance:
|
||||
| otherwise = (False,[],[])
|
||||
|
||||
|
||||
|
||||
-- | Generates all the given instances (eliminating any duplicates)
|
||||
-- with the given options. The return is a pair of a list of instances of PolyplateMRoute,
|
||||
-- and a list of instances of PolyplateSpine
|
||||
genInstances :: GenOverlappedOption -> GenClassOption -> [GenInstance] ->
|
||||
IO ([String], [String])
|
||||
IO [String]
|
||||
genInstances op1 op2 insts
|
||||
= do typeMap <- flip execStateT Map.empty (sequence [g | GenInstance g <- insts])
|
||||
let (inst, spineInst) = unzip [
|
||||
(instancesFrom op1 op2 (justBoxes typeMap) w
|
||||
,spineInstancesFrom op1 op2 (justBoxes typeMap) w)
|
||||
| DataBox w <- map witness $ justBoxes typeMap]
|
||||
let inst = [instancesFrom op1 op2 (justBoxes typeMap) w
|
||||
| DataBox w <- map witness $ justBoxes typeMap]
|
||||
inst' <- sequence inst
|
||||
spineInst' <- sequence spineInst
|
||||
return (concat inst', concat spineInst')
|
||||
return $ concat inst'
|
||||
-- | Generates the instances according to the options and writes it to stdout with
|
||||
-- the given header (the header is a list of lines without newline characters).
|
||||
writeInstances :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> [String] -> IO ()
|
||||
writeInstances op1 op2 inst header
|
||||
= do (instLines, spineInstLines) <- genInstances op1 op2 inst
|
||||
putStr (unlines (header ++ instLines ++ spineInstLines))
|
||||
|
||||
-- | Generates the instances according to the options and writes the PolyplateMRoute
|
||||
-- instances with the first header (the header is a list of lines without newline characters)
|
||||
-- to the first filename, and the PolyplateSpine instances with the second header
|
||||
-- to the second filename.
|
||||
writeInstancesToSep :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> ([String],
|
||||
[String]) -> (FilePath, FilePath) -> IO ()
|
||||
writeInstancesToSep op1 op2 inst (header1, header2) (fileName1, fileName2)
|
||||
= do (instLines, spineInstLines) <- genInstances op1 op2 inst
|
||||
writeFile fileName1 (unlines (header1 ++ instLines))
|
||||
writeFile fileName2 (unlines (header2 ++ spineInstLines))
|
||||
= do instLines <- genInstances op1 op2 inst
|
||||
putStr (unlines (header ++ instLines))
|
||||
|
||||
-- | Generates the instances according to the options and writes it to a file with
|
||||
-- the given header (the header is a list of lines without newline characters).
|
||||
writeInstancesTo :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> [String]
|
||||
-> FilePath -> IO ()
|
||||
writeInstancesTo op1 op2 inst header fileName
|
||||
= do (instLines, spineInstLines) <- genInstances op1 op2 inst
|
||||
writeFile fileName (unlines (header ++ instLines ++ spineInstLines))
|
||||
= do instLines <- genInstances op1 op2 inst
|
||||
writeFile fileName (unlines (header ++ instLines))
|
||||
|
||||
|
||||
--{{{ Various SYB-based functions that we don't export, for discovering contained types:
|
||||
|
|
|
|||
|
|
@ -19,8 +19,7 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
|
|||
|
||||
module Data.Generics.Polyplate.Schemes where
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Tree
|
||||
import Control.Monad.State
|
||||
|
||||
import Data.Generics.Polyplate
|
||||
import Data.Generics.Polyplate.Route
|
||||
|
|
@ -81,52 +80,17 @@ makeCheckM ops f v
|
|||
descend = makeDescend ops
|
||||
-}
|
||||
|
||||
-- * Query functions that return rose-trees of results
|
||||
|
||||
-- | Given a query function that turns all items of type \"s\" into results of
|
||||
-- type \"a\", applies the function to every instance of \"s\" inside a larger
|
||||
-- structure of type \"t\", and gives the resulting values of type \"a\" back in
|
||||
-- a rose-tree. A node in the tree will be generated for every constructor in
|
||||
-- the larger item (of type \"t\"). If the constructor was of type \"s\", the
|
||||
-- corresponding tree node will contain Just (the result of the query function).
|
||||
-- If the constructor was any other type, the corresponding tree node will contain
|
||||
-- Nothing.
|
||||
--
|
||||
-- Also note that the result is trimmed. If a particular sub-tree has no items
|
||||
-- of the target type, instead of getting a whole sub-tree with Nothing values,
|
||||
-- you will get one node (at the top of the sub-tree) with a Nothing value. This
|
||||
-- is to make the traversal more efficient, in terms of time and space.
|
||||
applyQuery :: PolyplateSpine t (OneOpQ a s) () a => (s -> a) -> t -> Tree (Maybe a)
|
||||
applyQuery qf = transformSpine ops ()
|
||||
where
|
||||
ops = baseOp `extOpQ` qf
|
||||
|
||||
-- | As 'applyQuery', but takes two query functions that act on different types
|
||||
-- (\"sA\" and \"sB\") but return the same result type (\"a\").
|
||||
applyQuery2 :: PolyplateSpine t (TwoOpQ a sA sB) () a => (sA -> a) -> (sB -> a) -> t -> Tree (Maybe a)
|
||||
applyQuery2 qfA qfB = transformSpine ops ()
|
||||
where
|
||||
ops = baseOp `extOpQ` qfA `extOpQ` qfB
|
||||
|
||||
-- * Listify functions that return lists of items that satisfy given criteria
|
||||
|
||||
-- | Given a function that examines a type \"s\" and gives an answer (True to include
|
||||
-- the item in the list, False to drop it), finds all items of type \"s\" in some
|
||||
-- larger item (of type \"t\") that satisfy this function, listed in depth-first
|
||||
-- order.
|
||||
listifyDepth :: PolyplateSpine t (OneOpQ (Maybe s) s) () (Maybe s) => (s -> Bool) -> t -> [s]
|
||||
listifyDepth qf = catMaybes . flatten . fmap (fromMaybe Nothing) . transformSpine ops ()
|
||||
listifyTopDown :: (PolyplateM t (OneOpM (State [s]) s) () (State [s])
|
||||
,PolyplateM s () (OneOpM (State [s]) s) (State [s])) => (s -> Bool) -> t -> [s]
|
||||
listifyTopDown qf = flip execState [] . applyBottomUpM qf'
|
||||
where
|
||||
qf' x = if qf x then Just x else Nothing
|
||||
ops = baseOp `extOpQ` qf'
|
||||
|
||||
-- | As 'listifyDepth', but the returned list is in breadth-first order.
|
||||
listifyBreadth :: PolyplateSpine t (OneOpQ (Maybe s) s) () (Maybe s) => (s -> Bool) -> t -> [s]
|
||||
listifyBreadth qf = catMaybes . (concat . levels) . fmap (fromMaybe Nothing) . transformSpine ops ()
|
||||
where
|
||||
qf' x = if qf x then Just x else Nothing
|
||||
ops = baseOp `extOpQ` qf'
|
||||
|
||||
qf' x = if qf x then modify (x:) >> return x else return x
|
||||
|
||||
-- * Check functions to apply monadic checks throughout a data structure
|
||||
|
||||
|
|
@ -136,23 +100,19 @@ listifyBreadth qf = catMaybes . (concat . levels) . fmap (fromMaybe Nothing) . t
|
|||
--
|
||||
-- This can be used, for example, to perform checks on items in an error monad,
|
||||
-- or to accumulate information in a state monad.
|
||||
checkDepthM :: (Monad m, PolyplateSpine t (OneOpQ (m ()) s) () (m ())) => (s -> m ()) -> t -> m ()
|
||||
checkDepthM f = sequence_ . catMaybes . flatten . applyQuery f
|
||||
checkDepthM :: (Monad m, PolyplateM t (OneOpM m s) () m
|
||||
, PolyplateM s () (OneOpM m s) m) => (s -> m ()) -> t -> m ()
|
||||
checkDepthM f x = applyBottomUpM (\x -> f x >> return x) x >> return ()
|
||||
|
||||
-- | As 'checkDepthM', but takes two functions (one operating on type \"r\", the
|
||||
-- other on type \"s\").
|
||||
checkDepthM2 :: (Monad m, PolyplateSpine t (TwoOpQ (m ()) r s) () (m ())) =>
|
||||
checkDepthM2 :: (Monad m, PolyplateM t (TwoOpM m r s) () m
|
||||
, PolyplateM r () (TwoOpM m r s) m
|
||||
, PolyplateM s () (TwoOpM m r s) m
|
||||
) =>
|
||||
(r -> m ()) -> (s -> m ()) -> t -> m ()
|
||||
checkDepthM2 f g = sequence_ . catMaybes . flatten . applyQuery2 f g
|
||||
|
||||
-- | As 'checkDepthM', but applies the checks in breadth-first order.
|
||||
checkBreadthM :: (Monad m, PolyplateSpine t (OneOpQ (m ()) s) () (m ())) => (s -> m ()) -> t -> m ()
|
||||
checkBreadthM f = sequence_ . catMaybes . concat . levels . applyQuery f
|
||||
|
||||
-- | As 'checkDepthM2', but applies the checks in breadth-first order.
|
||||
checkBreadthM2 :: (Monad m, PolyplateSpine t (TwoOpQ (m ()) r s) () (m ())) =>
|
||||
(r -> m ()) -> (s -> m ()) -> t -> m ()
|
||||
checkBreadthM2 f g = sequence_ . catMaybes . concat . levels . applyQuery2 f g
|
||||
checkDepthM2 f g x = applyBottomUpM2 (\x -> f x >> return x)
|
||||
(\y -> g y >> return y) x >> return ()
|
||||
|
||||
-- * Functions to easily apply transformations throughout a data structure
|
||||
|
||||
|
|
|
|||
|
|
@ -31,8 +31,8 @@ import qualified Errors
|
|||
|
||||
main :: IO ()
|
||||
main = do
|
||||
[instFileName, spineInstFileName] <- getArgs
|
||||
writeInstancesToSep GenWithOverlapped GenClassPerType
|
||||
[instFileName] <- getArgs
|
||||
writeInstancesTo GenWithOverlapped GenOneClass
|
||||
[ genInstance (undefined :: AST.AST)
|
||||
, genInstance (undefined :: CompState.CompState)
|
||||
-- All the maps that are in CompState:
|
||||
|
|
@ -48,8 +48,8 @@ main = do
|
|||
, genSetInstance (undefined :: AST.Name)
|
||||
, genSetInstance (undefined :: CompState.NameAttr)
|
||||
]
|
||||
(header False (findModuleName instFileName), header True (findModuleName spineInstFileName))
|
||||
(instFileName, spineInstFileName)
|
||||
(header False (findModuleName instFileName))
|
||||
instFileName
|
||||
where
|
||||
findModuleName moduleFileName
|
||||
| not (".hs" `isSuffixOf` moduleFileName)
|
||||
|
|
|
|||
|
|
@ -263,7 +263,7 @@ abbrevCheckPass
|
|||
checkNotWritten (A.Variable m n) "VAL-abbreviated variable % written-to inside the scope of the abbreviation"
|
||||
sequence_ [checkNotWritten v
|
||||
"Abbreviated variable % used inside the scope of the abbreviation"
|
||||
| A.ExprVariable _ v <- listifyDepth (const True) e]
|
||||
| A.ExprVariable _ v <- listifyTopDown (const True) e]
|
||||
pop
|
||||
return s
|
||||
doStructured s = descend s
|
||||
|
|
@ -288,7 +288,7 @@ abbrevCheckPass
|
|||
checkAbbreved v@(A.Variable {}) msg = checkNone v msg
|
||||
checkAbbreved v@(A.DirectedVariable {}) msg = checkNone v msg
|
||||
checkAbbreved (A.SubscriptedVariable _ sub v) msg
|
||||
= sequence_ [checkNotWritten subV msg | subV <- listifyDepth (const True) sub]
|
||||
= sequence_ [checkNotWritten subV msg | subV <- listifyTopDown (const True) sub]
|
||||
|
||||
checkNone :: A.Variable -> String -> StateT [Map.Map Var Bool] PassM ()
|
||||
checkNone v msg
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user