summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2016-06-04 01:16:16 +0200
committerGregor Kleen <gkleen@yggdrasil.li>2016-06-04 01:16:16 +0200
commitc1fe5811daf9780bc4a822776c3eb5c920941d45 (patch)
treebe302fe9b3a26648b35d17b76b267730a7022fe8 /src
parentb6e4dcfd8b50f47f2ca781752b1b24c86cf8c962 (diff)
download2017-01-16_17:13:37-c1fe5811daf9780bc4a822776c3eb5c920941d45.tar
2017-01-16_17:13:37-c1fe5811daf9780bc4a822776c3eb5c920941d45.tar.gz
2017-01-16_17:13:37-c1fe5811daf9780bc4a822776c3eb5c920941d45.tar.bz2
2017-01-16_17:13:37-c1fe5811daf9780bc4a822776c3eb5c920941d45.tar.xz
2017-01-16_17:13:37-c1fe5811daf9780bc4a822776c3eb5c920941d45.zip
cleanup
Diffstat (limited to 'src')
-rw-r--r--src/Sequence/Contact/Types.hs6
-rw-r--r--src/Sequence/Formula.hs10
2 files changed, 9 insertions, 7 deletions
diff --git a/src/Sequence/Contact/Types.hs b/src/Sequence/Contact/Types.hs
index 815bd4e..b63b369 100644
--- a/src/Sequence/Contact/Types.hs
+++ b/src/Sequence/Contact/Types.hs
@@ -55,7 +55,7 @@ data Stats = Prop
55 , _sMaxVitality 55 , _sMaxVitality
56 , _sSeqVal 56 , _sSeqVal
57 , _sPainTolerance 57 , _sPainTolerance
58 , _sFatigueTolerance :: FormulaM Stats Int 58 , _sFatigueTolerance :: Formula Stats
59 } 59 }
60 | Quadruped 60 | Quadruped
61 { _sAStrength 61 { _sAStrength
@@ -78,7 +78,7 @@ data Stats = Prop
78 , _sMaxVitality 78 , _sMaxVitality
79 , _sSeqVal 79 , _sSeqVal
80 , _sPainTolerance 80 , _sPainTolerance
81 , _sFatigueTolerance :: FormulaM Stats Int 81 , _sFatigueTolerance :: Formula Stats
82 } 82 }
83 | Dolphin 83 | Dolphin
84 { _sAStrength 84 { _sAStrength
@@ -101,7 +101,7 @@ data Stats = Prop
101 , _sMaxVitality 101 , _sMaxVitality
102 , _sSeqVal 102 , _sSeqVal
103 , _sPainTolerance 103 , _sPainTolerance
104 , _sFatigueTolerance :: FormulaM Stats Int 104 , _sFatigueTolerance :: Formula Stats
105 } 105 }
106makeLenses ''Stats 106makeLenses ''Stats
107 107
diff --git a/src/Sequence/Formula.hs b/src/Sequence/Formula.hs
index 2a4541f..fc61efb 100644
--- a/src/Sequence/Formula.hs
+++ b/src/Sequence/Formula.hs
@@ -1,7 +1,7 @@
1{-# LANGUAGE RecordWildCards, RankNTypes, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, ViewPatterns, TypeFamilies #-} 1{-# LANGUAGE RecordWildCards, RankNTypes, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, ViewPatterns, TypeFamilies #-}
2 2
3module Sequence.Formula 3module Sequence.Formula
4 ( FormulaM 4 ( FormulaM, Formula
5 , evalFormula 5 , evalFormula
6 , val 6 , val
7 , d, z 7 , d, z
@@ -28,8 +28,10 @@ import Data.Maybe
28 28
29type FormulaM input a = ReaderT input (ExceptT (Question input) EventM) a 29type FormulaM input a = ReaderT input (ExceptT (Question input) EventM) a
30 30
31type Formula input = Formulam input Int
32
31data Question input = Question 33data Question input = Question
32 { answer :: Traversal' input (FormulaM input Int) 34 { answer :: Traversal' input (Formula input)
33 , prompt :: String 35 , prompt :: String
34 , keepResult :: Bool 36 , keepResult :: Bool
35 } 37 }
@@ -57,10 +59,10 @@ evalFormula = evalFormula' []
57 Left q@(Question{..}) -> askQuestion input q >>= flip (evalFormula' $ bool (pure . set answer $ throwError q) mempty keepResult ++ finalChanges) formula 59 Left q@(Question{..}) -> askQuestion input q >>= flip (evalFormula' $ bool (pure . set answer $ throwError q) mempty keepResult ++ finalChanges) formula
58 Right result -> return (foldr ($) input finalChanges, result) 60 Right result -> return (foldr ($) input finalChanges, result)
59 61
60val :: Integral a => Traversal' input (FormulaM input Int) -> String -> Bool -> FormulaM input Int 62val :: Integral a => Traversal' input (Formula input) -> String -> Bool -> Formula input
61val answer prompt keepResult = preview answer >>= maybe (throwError Question{..}) id 63val answer prompt keepResult = preview answer >>= maybe (throwError Question{..}) id
62 64
63-- viewL :: Lens' lInput sInput -> Iso' (FormulaM sInput a) (FormulaM lInput a) 65-- viewL :: Lens' lInput sInput -> Prism' (FormulaM sInput a) (FormulaM lInput a)
64-- viewL lTrav = iso asL asS 66-- viewL lTrav = iso asL asS
65-- where 67-- where
66-- asL small = join $ lift . withExceptT (\Question{..} -> Question{ answer = lTrav . answer . viewL lTrav, .. }) . runReaderT small <$> view lTrav 68-- asL small = join $ lift . withExceptT (\Question{..} -> Question{ answer = lTrav . answer . viewL lTrav, .. }) . runReaderT small <$> view lTrav