module Alga.Language.Environment
( AlgaEnv
, HasEnv (..)
, runAlgaEnv
, addDef
, remDef
, clearDefs
, getPrin
, getSrc
, fullSrc
, getRefs
, purgeEnv
, checkRecur )
where
import Alga.Language.SyntaxTree
import Alga.Representation.Base (extremumAlias, panAlias)
import Alga.Representation.Show (showDefinition)
import Control.Arrow ((***), (>>>))
import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Ratio ((%))
import Data.Text.Lazy (Text)
import Numeric.Natural
import System.Console.Haskeline.MonadException
import System.Random (split)
import System.Random.TF (TFGen, mkTFGen)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as M
data AlgaEnvSt = AlgaEnvSt
{ aeDefs :: Defs
, aeRandGen :: TFGen
} deriving Show
type Defs = Map String SyntaxTree
newtype AlgaEnv m a = AlgaEnv
{ unAlgaEnv :: StateT AlgaEnvSt m a }
deriving ( Functor
, Applicative
, Monad
, MonadIO
, MonadState AlgaEnvSt
, MonadException
, MonadThrow
, MonadCatch
, MonadMask )
class Monad m => HasEnv m where
getDefs :: m Defs
setDefs :: Defs -> m ()
setRandGen :: Natural -> m ()
newRandGen :: m TFGen
instance Monad m => HasEnv (AlgaEnv m) where
getDefs = gets aeDefs
setDefs defs = modify $ \env -> env { aeDefs = defs }
setRandGen gen = modify $ \e -> e { aeRandGen = mkTFGen (fromIntegral gen) }
newRandGen = do
(g, g') <- split <$> gets aeRandGen
modify $ \e -> e { aeRandGen = g' }
return g
instance HasEnv m => HasEnv (StateT e m) where
getDefs = lift getDefs
setDefs = lift . setDefs
setRandGen = lift . setRandGen
newRandGen = lift newRandGen
instance HasEnv m => HasEnv (ReaderT e m) where
getDefs = lift getDefs
setDefs = lift . setDefs
setRandGen = lift . setRandGen
newRandGen = lift newRandGen
runAlgaEnv :: Monad m => AlgaEnv m a -> m a
runAlgaEnv e = evalStateT (unAlgaEnv e) AlgaEnvSt
{ aeDefs = defaultDefs
, aeRandGen = mkTFGen 0 }
defaultDefs :: Defs
defaultDefs = M.fromList
[ (a, [Value 0])
, (b, [Value 1])
, (l, [Value 0])
, (c, [Value (1 % 2)])
, (r, [Value 1]) ]
where (a, b) = extremumAlias
(l, c, r) = panAlias
addDef :: HasEnv m
=> String
-> SyntaxTree
-> m ()
addDef name tree = getDefs >>= setDefs . M.insert name tree
remDef :: HasEnv m
=> String
-> m ()
remDef name = getDefs >>= setDefs . M.delete name
clearDefs :: HasEnv m => m ()
clearDefs = setDefs defaultDefs
getPrin :: HasEnv m
=> String
-> m SyntaxTree
getPrin name = (fromMaybe [] . M.lookup name) <$> getDefs
getSrc :: HasEnv m
=> String
-> m Text
getSrc name = showDefinition name <$> getPrin name
fullSrc :: HasEnv m => m Text
fullSrc = (M.foldMapWithKey showDefinition . (M.\\ defaultDefs)) <$> getDefs
getRefs :: HasEnv m => m [String]
getRefs = M.keys <$> getDefs
tDefs
:: String
-> Defs
-> [String]
tDefs name defs = maybe mzero cm $ name `M.lookup` defs
where cm = (>>= f)
f (Value _) = mempty
f (Section x) = cm x
f (Multi x) = cm x
f (CMulti x) = NE.toList x >>= (cm *** cm >>> uncurry (<>))
f (Reference x) = return x <> tDefs x defs
f (Range _ _) = mempty
f (Product x y) = f x <> f y
f (Division x y) = f x <> f y
f (Sum x y) = f x <> f y
f (Diff x y) = f x <> f y
f (Loop x y) = f x <> f y
f (Rotation x y) = f x <> f y
f (Reverse x) = f x
purgeEnv :: HasEnv m
=> [String]
-> m ()
purgeEnv tops = f <$> getDefs >>= setDefs
where f defs = M.intersection defs $ M.unions [ts, ms defs, defaultDefs]
ms = M.unions . fmap toDefs . zipWith tDefs tops . repeat
ts = toDefs tops
checkRecur :: HasEnv m
=> String
-> SyntaxTree
-> m Bool
checkRecur name tree = check <$> getDefs
where check = elem name . tDefs name . M.insert name tree
toDefs :: [String] -> Defs
toDefs = M.fromList . fmap (, [])