suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Removed PolyplateSpine in favour of using PolyplateM (and the State monad) everywhere

Browse Source
This commit is contained in:
Neil Brown 2009-04-13 20:37:14 +00:00
parent 04974ae470
commit f2c4ada01b
15 changed files with 86 additions and 473 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
Makefile.am
View File

@ -106,7 +106,7 @@ modulesdir=$(TOCKMODDIR)
tockincdir=$(TOCKINCDIR) tockincdir=$(TOCKINCDIR)
tocklibdir=$(TOCKLIBDIR) 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,@@pkgincludedir@@,$(pkgincludedir),g' config/Paths.hs.in \
| sed -e 's,@@tockdir@@,$(TOCKDIR),g' \ | sed -e 's,@@tockdir@@,$(TOCKDIR),g' \
| sed -e 's,@@tockmoddir@@,$(TOCKMODDIR),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 | sed -e 's,@@tocklibdir@@,$(TOCKLIBDIR),g' >config/Paths.hs
data/NavAST.hs: GenNavAST$(EXEEXT) data/NavAST.hs: GenNavAST$(EXEEXT)
./GenNavAST$(EXEEXT) data/NavAST.hs data/NavASTSpine.hs ./GenNavAST$(EXEEXT) data/NavAST.hs
data/NavASTSpine.hs: GenNavAST$(EXEEXT)
./GenNavAST$(EXEEXT) data/NavAST.hs data/NavASTSpine.hs
data/OrdAST.hs: GenOrdAST$(EXEEXT) data/OrdAST.hs: GenOrdAST$(EXEEXT)
./GenOrdAST$(EXEEXT) > data/OrdAST.hs ./GenOrdAST$(EXEEXT) > data/OrdAST.hs
@ -130,7 +127,6 @@ config_sources += config/Paths.hs
config_sources += config/TypeSizes.hs config_sources += config/TypeSizes.hs
BUILT_SOURCES = data/NavAST.hs BUILT_SOURCES = data/NavAST.hs
BUILT_SOURCES += data/NavASTSpine.hs
BUILT_SOURCES += data/OrdAST.hs BUILT_SOURCES += data/OrdAST.hs
BUILT_SOURCES += data/TagAST.hs BUILT_SOURCES += data/TagAST.hs
BUILT_SOURCES += frontends/LexOccam.hs BUILT_SOURCES += frontends/LexOccam.hs
@ -233,7 +229,7 @@ tocktest_SOURCES += transformations/PassTest.hs
tocktest_SOURCES += transformations/SimplifyAbbrevsTest.hs tocktest_SOURCES += transformations/SimplifyAbbrevsTest.hs
tocktest_SOURCES += transformations/SimplifyTypesTest.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 += pregen/PregenUtils.hs
pregen_sources += polyplate/Data/Generics/Polyplate/GenInstances.hs pregen_sources += polyplate/Data/Generics/Polyplate/GenInstances.hs

4
backends/GenerateC.hs
View File

@ -182,11 +182,11 @@ cgenTopLevel headerName s
= A.nameName n `elem` (csOriginalTopLevelProcs cs) = A.nameName n `elem` (csOriginalTopLevelProcs cs)
tellToHeader $ sequence_ $ map (call genForwardDeclaration) tellToHeader $ sequence_ $ map (call genForwardDeclaration)
(listifyDepth isTopLevelSpec s) (listifyTopDown isTopLevelSpec s)
-- Things like lifted wrapper_procs we still need to forward-declare, -- Things like lifted wrapper_procs we still need to forward-declare,
-- but we do it in the C file, not in the header: -- but we do it in the C file, not in the header:
sequence_ $ map (call genForwardDeclaration) sequence_ $ map (call genForwardDeclaration)
(listifyDepth (not . isTopLevelSpec) s) (listifyTopDown (not . isTopLevelSpec) s)
tell ["#include \"", dropPath headerName, "\"\n"] tell ["#include \"", dropPath headerName, "\"\n"]

4
backends/GenerateCPPCSP.hs
View File

@ -144,11 +144,11 @@ cppgenTopLevel headerName s
= A.nameName n `elem` (csOriginalTopLevelProcs cs) = A.nameName n `elem` (csOriginalTopLevelProcs cs)
tellToHeader $ sequence_ $ map (call genForwardDeclaration) tellToHeader $ sequence_ $ map (call genForwardDeclaration)
(listifyDepth isTopLevelSpec s) (listifyTopDown isTopLevelSpec s)
-- Things like lifted wrapper_procs we still need to forward-declare, -- Things like lifted wrapper_procs we still need to forward-declare,
-- but we do it in the C file, not in the header: -- but we do it in the C file, not in the header:
sequence_ $ map (call genForwardDeclaration) sequence_ $ map (call genForwardDeclaration)
(listifyDepth (\sp@(A.Specification _ n _) (listifyTopDown (\sp@(A.Specification _ n _)
-> not (isTopLevelSpec sp) -> not (isTopLevelSpec sp)
&& A.nameName n `notElem` map fst (csExternals cs)) s) && A.nameName n `notElem` map fst (csExternals cs)) s)

12
checks/Check.hs
View File

@ -107,12 +107,12 @@ followBK = map followBK'
next = Set.fromList $ map Var $ concatMap allVarsInBK bk next = Set.fromList $ map Var $ concatMap allVarsInBK bk
allVarsInBK :: BackgroundKnowledge -> [A.Variable] allVarsInBK :: BackgroundKnowledge -> [A.Variable]
allVarsInBK (Equal a b) = listifyDepth (const True) a allVarsInBK (Equal a b) = listifyTopDown (const True) a
++ listifyDepth (const True) b ++ listifyTopDown (const True) b
allVarsInBK (LessThanOrEqual a b) = listifyDepth (const True) a allVarsInBK (LessThanOrEqual a b) = listifyTopDown (const True) a
++ listifyDepth (const True) b ++ listifyTopDown (const True) b
allVarsInBK (RepBoundsIncl v a b) = v : (listifyDepth (const True) a allVarsInBK (RepBoundsIncl v a b) = v : (listifyTopDown (const True) a
++ listifyDepth (const True) b) ++ listifyTopDown (const True) b)
data And a = And [a] data And a = And [a]
data Or a = Or [a] data Or a = Or [a]

2
checks/UsageCheckAlgorithms.hs
View File

@ -204,7 +204,7 @@ findConstraints graph startNode
processNode (n, e) nodeVal curAgg = case fmap getNodeData $ lab graph n of processNode (n, e) nodeVal curAgg = case fmap getNodeData $ lab graph n of
Just u -> Just u ->
let overlapsWithWritten e = not $ null $ intersect let overlapsWithWritten e = not $ null $ intersect
(listifyDepth (const True) $ snd e) (listifyTopDown (const True) $ snd e)
[v | Var v <- Map.keys $ writtenVars $ nodeVars u] [v | Var v <- Map.keys $ writtenVars $ nodeVars u]
valFilt = filter (not . overlapsWithWritten) $ valFilt = filter (not . overlapsWithWritten) $
nub $ nodeVal ++ (case e of nub $ nodeVal ++ (case e of

28
frontends/OccamTypes.hs
View File

@ -1307,10 +1307,14 @@ inferTypes = occamOnlyPass "Infer types"
-- This is actually a series of smaller passes that check particular 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. -- inside the AST, but it doesn't really make sense to split it up.
checkTypes :: checkTypes ::
(PolyplateSpine t (OneOpQ (PassM ()) A.Variable) () (PassM ()) (PolyplateM t (OneOpM PassM A.Variable) () PassM
,PolyplateSpine t (OneOpQ (PassM ()) A.Expression) () (PassM ()) ,PolyplateM t (OneOpM PassM A.Expression) () PassM
,PolyplateSpine t (OneOpQ (PassM ()) A.SpecType) () (PassM ()) ,PolyplateM t (OneOpM PassM A.SpecType) () PassM
,PolyplateSpine t (OneOpQ (PassM ()) A.Process) () (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 ) => Pass t
checkTypes = occamOnlyPass "Check types" checkTypes = occamOnlyPass "Check types"
[Prop.inferredTypesRecorded, Prop.ambiguitiesResolved] [Prop.inferredTypesRecorded, Prop.ambiguitiesResolved]
@ -1326,8 +1330,8 @@ checkTypes = occamOnlyPass "Check types"
--{{{ checkVariables --{{{ checkVariables
checkVariables :: PlainCheckOn A.Variable checkVariables :: PassTypeOn A.Variable
checkVariables = checkDepthM doVariable checkVariables x = checkDepthM doVariable x >> return x
where where
doVariable :: Check A.Variable doVariable :: Check A.Variable
doVariable (A.SubscriptedVariable m s v) doVariable (A.SubscriptedVariable m s v)
@ -1357,8 +1361,8 @@ checkVariables = checkDepthM doVariable
--}}} --}}}
--{{{ checkExpressions --{{{ checkExpressions
checkExpressions :: PlainCheckOn A.Expression checkExpressions :: PassTypeOn A.Expression
checkExpressions = checkDepthM doExpression checkExpressions x = checkDepthM doExpression x >> return x
where where
doExpression :: Check A.Expression doExpression :: Check A.Expression
doExpression (A.MostPos m t) = checkNumeric m t doExpression (A.MostPos m t) = checkNumeric m t
@ -1409,8 +1413,8 @@ checkExpressions = checkDepthM doExpression
--}}} --}}}
--{{{ checkSpecTypes --{{{ checkSpecTypes
checkSpecTypes :: PlainCheckOn A.SpecType checkSpecTypes :: PassTypeOn A.SpecType
checkSpecTypes = checkDepthM doSpecType checkSpecTypes x = checkDepthM doSpecType x >> return x
where where
doSpecType :: Check A.SpecType doSpecType :: Check A.SpecType
doSpecType (A.Place _ e) = checkExpressionInt e doSpecType (A.Place _ e) = checkExpressionInt e
@ -1532,8 +1536,8 @@ checkSpecTypes = checkDepthM doSpecType
--}}} --}}}
--{{{ checkProcesses --{{{ checkProcesses
checkProcesses :: PlainCheckOn A.Process checkProcesses :: PassTypeOn A.Process
checkProcesses = checkDepthM doProcess checkProcesses x = checkDepthM doProcess x >> return x
where where
doProcess :: Check A.Process doProcess :: Check A.Process
doProcess (A.Assign m vs el) doProcess (A.Assign m vs el)

24
frontends/OccamTypesTest.hs
View File

@ -502,20 +502,28 @@ testOccamTypes = TestList
--}}} --}}}
] ]
where where
testOK :: (PolyplateSpine a (OneOpQ (PassM ()) A.Variable) () (PassM ()) testOK :: (PolyplateM a (OneOpM PassM A.Variable) () PassM
,PolyplateSpine a (OneOpQ (PassM ()) A.Expression) () (PassM ()) ,PolyplateM a (OneOpM PassM A.Expression) () PassM
,PolyplateSpine a (OneOpQ (PassM ()) A.SpecType) () (PassM ()) ,PolyplateM a (OneOpM PassM A.SpecType) () PassM
,PolyplateSpine a (OneOpQ (PassM ()) A.Process) () (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 ,Show a, Data a) => Int -> a -> Test
testOK n orig testOK n orig
= TestCase $ testPass ("testOccamTypes " ++ show n) = TestCase $ testPass ("testOccamTypes " ++ show n)
orig OccamTypes.checkTypes orig orig OccamTypes.checkTypes orig
startState startState
testFail :: (PolyplateSpine a (OneOpQ (PassM ()) A.Variable) () (PassM ()) testFail :: (PolyplateM a (OneOpM PassM A.Variable) () PassM
,PolyplateSpine a (OneOpQ (PassM ()) A.Expression) () (PassM ()) ,PolyplateM a (OneOpM PassM A.Expression) () PassM
,PolyplateSpine a (OneOpQ (PassM ()) A.SpecType) () (PassM ()) ,PolyplateM a (OneOpM PassM A.SpecType) () PassM
,PolyplateSpine a (OneOpQ (PassM ()) A.Process) () (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 ,Show a, Data a) => Int -> a -> Test
testFail n orig testFail n orig
= TestCase $ testPassShouldFail ("testOccamTypes " ++ show n) = TestCase $ testPassShouldFail ("testOccamTypes " ++ show n)

18
frontends/RainTypes.hs
View File

@ -61,11 +61,11 @@ type RainTypeM = StateT RainTypeState PassM
type RainTypePassType = forall t. t -> StateT RainTypeState PassM t type RainTypePassType = forall t. t -> StateT RainTypeState PassM t
type RainTypeCheckOn a = forall t. PolyplateSpine t (OneOpQ (RainTypeM ()) a) () type RainTypeCheckOn a = forall t. PolyplateM t (OneOpM RainTypeM a) () RainTypeM
(RainTypeM ()) => t -> RainTypeM () => t -> RainTypeM ()
type RainTypeCheckOn2 a b = forall t. type RainTypeCheckOn2 a b = forall t.
(PolyplateSpine t (TwoOpQ (RainTypeM ()) a b) () (RainTypeM ()) (PolyplateM t (TwoOpM RainTypeM a b) () RainTypeM
) => t -> RainTypeM () ) => t -> RainTypeM ()
@ -128,12 +128,12 @@ markUnify x y
performTypeUnification :: performTypeUnification ::
-- | A shorthand for prerequisites when you need to spell them out: -- | A shorthand for prerequisites when you need to spell them out:
(PolyplateSpine t (OneOpQ (RainTypeM ()) A.Specification) () (RainTypeM ()) (PolyplateM t (OneOpM RainTypeM A.Specification) () RainTypeM
,PolyplateSpine t (OneOpQ (RainTypeM ()) A.Process) () (RainTypeM ()) ,PolyplateM t (OneOpM RainTypeM A.Process) () RainTypeM
,PolyplateSpine t (OneOpQ (RainTypeM ()) A.Expression) () (RainTypeM ()) ,PolyplateM t (OneOpM RainTypeM A.Expression) () RainTypeM
,PolyplateSpine t (TwoOpQ (RainTypeM ()) A.Process A.Expression) () (RainTypeM ()) ,PolyplateM t (TwoOpM RainTypeM A.Process A.Expression) () RainTypeM
,PolyplateSpine t (TwoOpQ (RainTypeM ()) A.Process A.Choice) () (RainTypeM ()) ,PolyplateM t (TwoOpM RainTypeM A.Process A.Choice) () RainTypeM
,PolyplateSpine t (TwoOpQ (RainTypeM ()) A.Process A.Alternative) () (RainTypeM ()) ,PolyplateM t (TwoOpM RainTypeM A.Process A.Alternative) () RainTypeM
,PolyplateM t () (OneOpM PassM A.Type) PassM ,PolyplateM t () (OneOpM PassM A.Type) PassM
,PolyplateM t (OneOpM PassM A.Type) () PassM ,PolyplateM t (OneOpM PassM A.Type) () PassM
) => Pass t ) => Pass t

8
pass/Pass.hs
View File

@ -61,12 +61,6 @@ type PassOnOpsM m ops
type PassOnOps ops = PassOnOpsM PassM 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 type PassASTOnOps ops
= (PolyplateM A.AST ops () PassM, PolyplateM A.AST () ops PassM) => Pass A.AST = (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 PassOn t = PassOnOps (OneOpM PassM t)
type PassOn2 s t = PassOnOps (TwoOpM PassM s t) type PassOn2 s t = PassOnOps (TwoOpM PassM s t)
type PassTypeOn t = PassTypeOnOps (OneOpM PassM 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. -- | A description of an AST-mangling pass.
data Pass t = Pass { data Pass t = Pass {

59
pass/Traversal.hs
View File

@ -22,7 +22,6 @@ module Traversal (
TransformM, Transform, TransformStructured, TransformStructured', TransformStructuredM' TransformM, Transform, TransformStructured, TransformStructured', TransformStructuredM'
, CheckM, Check , CheckM, Check
, ExtOpMP, ExtOpMS, ExtOpMSP, extOpMS, PassOnStruct, PassASTOnStruct , ExtOpMP, ExtOpMS, ExtOpMSP, extOpMS, PassOnStruct, PassASTOnStruct
, ExtOpQS, extOpQS
, applyBottomUpMS, ASTStructured , applyBottomUpMS, ASTStructured
, module Data.Generics.Polyplate , module Data.Generics.Polyplate
, module Data.Generics.Polyplate.Schemes , module Data.Generics.Polyplate.Schemes
@ -36,7 +35,6 @@ import Data.Generics.Polyplate.Schemes
import qualified AST as A import qualified AST as A
import NavAST() import NavAST()
import NavASTSpine()
import Pass import Pass
-- | A transformation for a single 'Data' type. -- | A transformation for a single 'Data' type.
@ -71,52 +69,36 @@ type PassASTOnStruct = PassASTOnOps (ExtOpMSP BaseOp)
class (PolyplateM (A.Structured a) () opsM m class (PolyplateM (A.Structured a) () opsM m
,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 ,Data a
,Monad m ,Monad m
) => ASTStructured a opsM m opsQ r ) => ASTStructured a opsM m opsQ r
instance (PolyplateM (A.Structured ()) () opsM m instance (PolyplateM (A.Structured ()) () opsM m
,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 ,Monad m) => ASTStructured () opsM m opsQ r
instance (PolyplateM (A.Structured A.Alternative) () opsM m instance (PolyplateM (A.Structured A.Alternative) () opsM m
,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 ,Monad m) => ASTStructured A.Alternative opsM m opsQ r
instance (PolyplateM (A.Structured A.Choice) () opsM m instance (PolyplateM (A.Structured A.Choice) () opsM m
,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 ,Monad m) => ASTStructured A.Choice opsM m opsQ r
instance (PolyplateM (A.Structured A.ExpressionList) () opsM m instance (PolyplateM (A.Structured A.ExpressionList) () opsM m
,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 ,Monad m) => ASTStructured A.ExpressionList opsM m opsQ r
instance (PolyplateM (A.Structured A.Option) () opsM m instance (PolyplateM (A.Structured A.Option) () opsM m
,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 ,Monad m) => ASTStructured A.Option opsM m opsQ r
instance (PolyplateM (A.Structured A.Process) () opsM m instance (PolyplateM (A.Structured A.Process) () opsM m
,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 ,Monad m) => ASTStructured A.Process opsM m opsQ r
instance (PolyplateM (A.Structured A.Variant) () opsM m instance (PolyplateM (A.Structured A.Variant) () opsM m
,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 ,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 A.Alternative -> m (A.Structured A.Alternative))
`extOpM` (f :: A.Structured () -> m (A.Structured ())) `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) => applyBottomUpMS :: (PolyplateM t (ExtOpMSP BaseOp) () PassM) =>
(forall a. (Data a, PolyplateM (A.Structured a) () (ExtOpMSP BaseOp) PassM) => (forall a. (Data a, PolyplateM (A.Structured a) () (ExtOpMSP BaseOp) PassM) =>
(A.Structured a -> PassM (A.Structured a))) (A.Structured a -> PassM (A.Structured a)))

92
polyplate/Data/Generics/Polyplate.hs
View File

@ -124,14 +124,13 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
-- --
-- TODO include an example with routes -- TODO include an example with routes
module Data.Generics.Polyplate (PolyplateMRoute(..), PolyplateM(..), Polyplate(..), module Data.Generics.Polyplate (PolyplateMRoute(..), PolyplateM(..), Polyplate(..),
PolyplateSpine(..), {-FullSpine(..),-} transformSpine, {-transformSpineFull,-} trimTree,
makeRecurseM, RecurseM, makeRecurse, Recurse, makeRecurseM, RecurseM, makeRecurse, Recurse,
makeDescendM, DescendM, makeDescend, Descend, makeDescendM, DescendM, makeDescend, Descend,
-- makeRecurseQ, RecurseQ, -- makeRecurseQ, RecurseQ,
-- makeDescendQ, DescendQ, -- makeDescendQ, DescendQ,
BaseOp, baseOp, BaseOp, baseOp,
ExtOpM, extOpM, ExtOpMRoute, extOpMRoute, ExtOp, extOp, OneOpM, OneOp, TwoOpM, TwoOp, ExtOpM, extOpM, ExtOpMRoute, extOpMRoute, ExtOp, extOp, OneOpM, OneOp, TwoOpM, TwoOp
ExtOpQ, extOpQ, OneOpQ, TwoOpQ) where ) where
import Control.Monad.Identity import Control.Monad.Identity
import Data.Maybe import Data.Maybe
@ -232,77 +231,6 @@ instance (Monad m
fakeRoute :: t -> Route t () fakeRoute :: t -> Route t ()
fakeRoute = const $ error "transformM" 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 non-monadic equivalent of PolyplateM. All ops sets are of the form:
-- --
-- > (a -> a, (b -> b, ())) -- > (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. -- for use with the 'Polyplate' class.
type ExtOp opT t = (t -> t, opT) 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 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 -- the given type (t). You cannot mix monadic and non-monadic operations in the
-- same list. This is for use with the 'PolyplateM' class. -- 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 :: opT -> (t -> t) -> ExtOp opT t
extOp ops f = (f, ops) 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'. -- | A handy synonym for a monadic ops set with only one item, to use with 'PolyplateM'.
type OneOpM m t = ExtOpM m BaseOp t type OneOpM m t = ExtOpM m BaseOp t
-- | A handy synonym for an ops set with only one item, to use with 'Polyplate'. -- | A handy synonym for an ops set with only one item, to use with 'Polyplate'.
type OneOp t = ExtOp BaseOp t 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'. -- | 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 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'. -- | A handy synonym for an ops set with only two items, to use with 'Polyplate'.
type TwoOp s t = ExtOp (ExtOp BaseOp s) t 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: -- {{{ Various type-level programming ops conversions:

216
polyplate/Data/Generics/Polyplate/GenInstances.hs
View File

@ -38,7 +38,7 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
module Data.Generics.Polyplate.GenInstances module Data.Generics.Polyplate.GenInstances
(GenOverlappedOption(..), GenClassOption(..), (GenOverlappedOption(..), GenClassOption(..),
GenInstance, genInstance, genMapInstance, genSetInstance, genInstances, GenInstance, genInstance, genMapInstance, genSetInstance, genInstances,
writeInstances, writeInstancesTo, writeInstancesToSep) where writeInstances, writeInstancesTo) where
import Control.Monad.State import Control.Monad.State
import Data.Char import Data.Char
@ -440,231 +440,31 @@ instancesFrom genOverlapped genClass boxes w
-- This is covered by one big overlapping instance: -- This is covered by one big overlapping instance:
| otherwise = (False,[],[]) | 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) -- | Generates all the given instances (eliminating any duplicates)
-- with the given options. The return is a pair of a list of instances of PolyplateMRoute, -- with the given options. The return is a pair of a list of instances of PolyplateMRoute,
-- and a list of instances of PolyplateSpine -- and a list of instances of PolyplateSpine
genInstances :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> genInstances :: GenOverlappedOption -> GenClassOption -> [GenInstance] ->
IO ([String], [String]) IO [String]
genInstances op1 op2 insts genInstances op1 op2 insts
= do typeMap <- flip execStateT Map.empty (sequence [g | GenInstance g <- insts]) = do typeMap <- flip execStateT Map.empty (sequence [g | GenInstance g <- insts])
let (inst, spineInst) = unzip [ let inst = [instancesFrom op1 op2 (justBoxes typeMap) w
(instancesFrom op1 op2 (justBoxes typeMap) w
,spineInstancesFrom op1 op2 (justBoxes typeMap) w)
| DataBox w <- map witness $ justBoxes typeMap] | DataBox w <- map witness $ justBoxes typeMap]
inst' <- sequence inst inst' <- sequence inst
spineInst' <- sequence spineInst return $ concat inst'
return (concat inst', concat spineInst')
-- | Generates the instances according to the options and writes it to stdout with -- | 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). -- the given header (the header is a list of lines without newline characters).
writeInstances :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> [String] -> IO () writeInstances :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> [String] -> IO ()
writeInstances op1 op2 inst header writeInstances op1 op2 inst header
= do (instLines, spineInstLines) <- genInstances op1 op2 inst = do instLines <- genInstances op1 op2 inst
putStr (unlines (header ++ instLines ++ spineInstLines)) putStr (unlines (header ++ instLines))
-- | 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))
-- | Generates the instances according to the options and writes it to a file with -- | 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). -- the given header (the header is a list of lines without newline characters).
writeInstancesTo :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> [String] writeInstancesTo :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> [String]
-> FilePath -> IO () -> FilePath -> IO ()
writeInstancesTo op1 op2 inst header fileName writeInstancesTo op1 op2 inst header fileName
= do (instLines, spineInstLines) <- genInstances op1 op2 inst = do instLines <- genInstances op1 op2 inst
writeFile fileName (unlines (header ++ instLines ++ spineInstLines)) writeFile fileName (unlines (header ++ instLines))
--{{{ Various SYB-based functions that we don't export, for discovering contained types: --{{{ Various SYB-based functions that we don't export, for discovering contained types:

68
polyplate/Data/Generics/Polyplate/Schemes.hs
View File

@ -19,8 +19,7 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
module Data.Generics.Polyplate.Schemes where module Data.Generics.Polyplate.Schemes where
import Data.Maybe import Control.Monad.State
import Data.Tree
import Data.Generics.Polyplate import Data.Generics.Polyplate
import Data.Generics.Polyplate.Route import Data.Generics.Polyplate.Route
@ -81,52 +80,17 @@ makeCheckM ops f v
descend = makeDescend ops 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 -- * 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 -- | 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 -- 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 -- larger item (of type \"t\") that satisfy this function, listed in depth-first
-- order. -- order.
listifyDepth :: PolyplateSpine t (OneOpQ (Maybe s) s) () (Maybe s) => (s -> Bool) -> t -> [s] listifyTopDown :: (PolyplateM t (OneOpM (State [s]) s) () (State [s])
listifyDepth qf = catMaybes . flatten . fmap (fromMaybe Nothing) . transformSpine ops () ,PolyplateM s () (OneOpM (State [s]) s) (State [s])) => (s -> Bool) -> t -> [s]
listifyTopDown qf = flip execState [] . applyBottomUpM qf'
where where
qf' x = if qf x then Just x else Nothing qf' x = if qf x then modify (x:) >> return x else return x
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'
-- * Check functions to apply monadic checks throughout a data structure -- * 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, -- This can be used, for example, to perform checks on items in an error monad,
-- or to accumulate information in a state monad. -- or to accumulate information in a state monad.
checkDepthM :: (Monad m, PolyplateSpine t (OneOpQ (m ()) s) () (m ())) => (s -> m ()) -> t -> m () checkDepthM :: (Monad m, PolyplateM t (OneOpM m s) () m
checkDepthM f = sequence_ . catMaybes . flatten . applyQuery f , 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 -- | As 'checkDepthM', but takes two functions (one operating on type \"r\", the
-- other on type \"s\"). -- 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 () (r -> m ()) -> (s -> m ()) -> t -> m ()
checkDepthM2 f g = sequence_ . catMaybes . flatten . applyQuery2 f g checkDepthM2 f g x = applyBottomUpM2 (\x -> f x >> return x)
(\y -> g y >> return y) x >> return ()
-- | 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
-- * Functions to easily apply transformations throughout a data structure -- * Functions to easily apply transformations throughout a data structure

8
pregen/GenNavAST.hs
View File

@ -31,8 +31,8 @@ import qualified Errors
main :: IO () main :: IO ()
main = do main = do
[instFileName, spineInstFileName] <- getArgs [instFileName] <- getArgs
writeInstancesToSep GenWithOverlapped GenClassPerType writeInstancesTo GenWithOverlapped GenOneClass
[ genInstance (undefined :: AST.AST) [ genInstance (undefined :: AST.AST)
, genInstance (undefined :: CompState.CompState) , genInstance (undefined :: CompState.CompState)
-- All the maps that are in CompState: -- All the maps that are in CompState:
@ -48,8 +48,8 @@ main = do
, genSetInstance (undefined :: AST.Name) , genSetInstance (undefined :: AST.Name)
, genSetInstance (undefined :: CompState.NameAttr) , genSetInstance (undefined :: CompState.NameAttr)
] ]
(header False (findModuleName instFileName), header True (findModuleName spineInstFileName)) (header False (findModuleName instFileName))
(instFileName, spineInstFileName) instFileName
where where
findModuleName moduleFileName findModuleName moduleFileName
| not (".hs" `isSuffixOf` moduleFileName) | not (".hs" `isSuffixOf` moduleFileName)

4
transformations/SimplifyAbbrevs.hs
View File

@ -263,7 +263,7 @@ abbrevCheckPass
checkNotWritten (A.Variable m n) "VAL-abbreviated variable % written-to inside the scope of the abbreviation" checkNotWritten (A.Variable m n) "VAL-abbreviated variable % written-to inside the scope of the abbreviation"
sequence_ [checkNotWritten v sequence_ [checkNotWritten v
"Abbreviated variable % used inside the scope of the abbreviation" "Abbreviated variable % used inside the scope of the abbreviation"
| A.ExprVariable _ v <- listifyDepth (const True) e] | A.ExprVariable _ v <- listifyTopDown (const True) e]
pop pop
return s return s
doStructured s = descend s doStructured s = descend s
@ -288,7 +288,7 @@ abbrevCheckPass
checkAbbreved v@(A.Variable {}) msg = checkNone v msg checkAbbreved v@(A.Variable {}) msg = checkNone v msg
checkAbbreved v@(A.DirectedVariable {}) msg = checkNone v msg checkAbbreved v@(A.DirectedVariable {}) msg = checkNone v msg
checkAbbreved (A.SubscriptedVariable _ sub 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 :: A.Variable -> String -> StateT [Map.Map Var Bool] PassM ()
checkNone v msg checkNone v msg