Migrate *ListElem functionality into just MapComp
This commit is contained in:
parent
c53f804074
commit
53e9598d22
|
@ -41,10 +41,10 @@ import Types.Values
|
||||||
import Types.Value (Valuable(..))
|
import Types.Value (Valuable(..))
|
||||||
import Types.Function (Function(..))
|
import Types.Function (Function(..))
|
||||||
import Types.FunctionIO (FunctionIO(..))
|
import Types.FunctionIO (FunctionIO(..))
|
||||||
import Types.Dependency (Action(..), Dependency, makeDependency)
|
import Types.Dependency (Action(..), Dependency, makeDependency, makeUToken)
|
||||||
|
|
||||||
import Control.Monad.State (MonadState, State, runState, put, get)
|
import Control.Monad.State (MonadState, State, runState, put, get)
|
||||||
import Control.Monad.Writer (MonadWriter, WriterT, execWriterT, tell)
|
import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
|
||||||
newtype DepGenM a = DepGenM { unDepGenM :: WriterT [Dependency] (State Int) a }
|
newtype DepGenM a = DepGenM { unDepGenM :: WriterT [Dependency] (State Int) a }
|
||||||
|
@ -52,21 +52,26 @@ newtype DepGenM a = DepGenM { unDepGenM :: WriterT [Dependency] (State Int) a }
|
||||||
|
|
||||||
type DepGenM' a = DepGenM (Token a)
|
type DepGenM' a = DepGenM (Token a)
|
||||||
|
|
||||||
evalDepGenM' :: Int -> DepGenM () -> ([Dependency], Int)
|
runDepGenM :: Int -> DepGenM a -> ((a, [Dependency]), Int)
|
||||||
evalDepGenM' top m = runState (execWriterT (unDepGenM m)) top
|
runDepGenM top m = runState (runWriterT (unDepGenM m)) top
|
||||||
|
|
||||||
evalDepGenM :: DepGenM () -> [Dependency]
|
evalDepGenM :: DepGenM () -> [Dependency]
|
||||||
evalDepGenM m = fst (evalDepGenM' 0 m)
|
evalDepGenM = snd . fst . runDepGenM 0
|
||||||
|
|
||||||
tellDep :: Dependency -> DepGenM ()
|
tellDep :: Dependency -> DepGenM ()
|
||||||
tellDep dep = tell [dep]
|
tellDep dep = tell [dep]
|
||||||
|
|
||||||
genDependencyM :: (Token a -> DepGenM Dependency) -> DepGenM' a
|
newToken :: DepGenM' a
|
||||||
genDependencyM f = do
|
newToken = do
|
||||||
top <- get
|
top <- get
|
||||||
let top' = top + 1
|
let top' = top + 1
|
||||||
target = Token top'
|
target = Token top'
|
||||||
put top'
|
put top'
|
||||||
|
pure target
|
||||||
|
|
||||||
|
genDependencyM :: (Token a -> DepGenM Dependency) -> DepGenM' a
|
||||||
|
genDependencyM f = do
|
||||||
|
target <- newToken
|
||||||
result <- f target
|
result <- f target
|
||||||
tellDep result
|
tellDep result
|
||||||
pure target
|
pure target
|
||||||
|
@ -77,13 +82,6 @@ genDependency f = genDependencyM (pure . f)
|
||||||
inject :: Valuable a => a -> DepGenM' a
|
inject :: Valuable a => a -> DepGenM' a
|
||||||
inject x = genDependency (makeDependency NoToken (Inject (toValue x)))
|
inject x = genDependency (makeDependency NoToken (Inject (toValue x)))
|
||||||
|
|
||||||
getListElem :: Token [a] -> DepGenM' a
|
|
||||||
getListElem outer = genDependency (makeDependency outer GetListElem)
|
|
||||||
|
|
||||||
setListElem :: Token a -> Token [a] -> DepGenM ()
|
|
||||||
setListElem a outer = do
|
|
||||||
tellDep (makeDependency a SetListElem outer)
|
|
||||||
|
|
||||||
runFunction :: Function -> Token a -> DepGenM' b
|
runFunction :: Function -> Token a -> DepGenM' b
|
||||||
runFunction f input = genDependency (makeDependency input (Function f))
|
runFunction f input = genDependency (makeDependency input (Function f))
|
||||||
|
|
||||||
|
@ -98,12 +96,12 @@ mapDepGenM f input = do
|
||||||
input' <- toToken input
|
input' <- toToken input
|
||||||
genDependencyM $ \target -> do
|
genDependencyM $ \target -> do
|
||||||
top <- get
|
top <- get
|
||||||
let (res, top') = evalDepGenM' top $ do
|
let (((innerInp, innerOutp), subDeps), top') = runDepGenM top $ do
|
||||||
inp <- getListElem input'
|
inp <- newToken
|
||||||
outp <- f inp
|
outp <- f inp
|
||||||
setListElem outp target
|
pure (inp, outp)
|
||||||
put top'
|
put top'
|
||||||
pure (makeDependency input' (MapComp res) target)
|
pure (makeDependency input' (MapComp subDeps (makeUToken innerInp) (makeUToken innerOutp)) target)
|
||||||
|
|
||||||
mapDepGenM_ :: TokenableTo [a] v => (Token a -> DepGenM ()) -> v -> DepGenM ()
|
mapDepGenM_ :: TokenableTo [a] v => (Token a -> DepGenM ()) -> v -> DepGenM ()
|
||||||
mapDepGenM_ f input = do
|
mapDepGenM_ f input = do
|
||||||
|
|
|
@ -66,10 +66,6 @@ runAction action input = case action of
|
||||||
pure $ List $ map fst $ filter (fromValue . snd) $ zip vs mask
|
pure $ List $ map fst $ filter (fromValue . snd) $ zip vs mask
|
||||||
_ ->
|
_ ->
|
||||||
error "unexpected"
|
error "unexpected"
|
||||||
GetListElem ->
|
|
||||||
undefined
|
|
||||||
SetListElem ->
|
|
||||||
undefined
|
|
||||||
UntupleFst ->
|
UntupleFst ->
|
||||||
case input of
|
case input of
|
||||||
Tuple (v, _) ->
|
Tuple (v, _) ->
|
||||||
|
@ -94,5 +90,5 @@ runAction action input = case action of
|
||||||
List <$> mapM (runAction UntupleSnd) vs
|
List <$> mapM (runAction UntupleSnd) vs
|
||||||
_ ->
|
_ ->
|
||||||
error "unexpected"
|
error "unexpected"
|
||||||
MapComp subDeps ->
|
MapComp subDeps innerInput innerOutput ->
|
||||||
undefined
|
undefined
|
||||||
|
|
|
@ -4,6 +4,7 @@ module Types.Dependency
|
||||||
, UToken(..)
|
, UToken(..)
|
||||||
, Dependency(..)
|
, Dependency(..)
|
||||||
, makeDependency
|
, makeDependency
|
||||||
|
, makeUToken
|
||||||
, formatDependencyTrees
|
, formatDependencyTrees
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
@ -21,13 +22,11 @@ data Action = Function Function
|
||||||
| FunctionIO FunctionIO
|
| FunctionIO FunctionIO
|
||||||
| Inject Value
|
| Inject Value
|
||||||
| FilterComp
|
| FilterComp
|
||||||
| GetListElem
|
|
||||||
| SetListElem
|
|
||||||
| UntupleFst
|
| UntupleFst
|
||||||
| UntupleSnd
|
| UntupleSnd
|
||||||
| UnzipFst
|
| UnzipFst
|
||||||
| UnzipSnd
|
| UnzipSnd
|
||||||
| MapComp [Dependency]
|
| MapComp [Dependency] UToken UToken
|
||||||
deriving (Show, Lift)
|
deriving (Show, Lift)
|
||||||
|
|
||||||
data UToken = UToken Int
|
data UToken = UToken Int
|
||||||
|
@ -83,8 +82,12 @@ formatDependencyTrees = T.concat . (formatDependencyTrees' "")
|
||||||
[ "--" ]
|
[ "--" ]
|
||||||
|
|
||||||
formatAction indentation = \case
|
formatAction indentation = \case
|
||||||
MapComp subDeps ->
|
MapComp subDeps innerInput innerOutput ->
|
||||||
concat [ [ "MapComp:\n" ]
|
concat [ [ "MapComp(" ]
|
||||||
|
, formatUToken innerInput
|
||||||
|
, [ " -> " ]
|
||||||
|
, formatUToken innerOutput
|
||||||
|
, [ "):\n" ]
|
||||||
, formatDependencyTrees' (T.append indentation "| ") subDeps
|
, formatDependencyTrees' (T.append indentation "| ") subDeps
|
||||||
]
|
]
|
||||||
action ->
|
action ->
|
||||||
|
|
Loading…
Reference in New Issue