never executed always true always false

    1 {-# LANGUAGE BangPatterns #-}
    2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    3 
    4 module Conjure.Language.NameGen (
    5     NameGen,
    6     NameGenM,
    7     NameGenState,
    8     nextName,
    9     exportNameGenState,
   10     importNameGenState,
   11     runNameGen,
   12 ) where
   13 
   14 -- conjure
   15 
   16 import Conjure.Language.Name
   17 import Conjure.Prelude
   18 import Conjure.UserError
   19 
   20 -- containers
   21 import Data.Map.Strict as M
   22 import Data.Set as S
   23 
   24 -- pipes
   25 import qualified Pipes
   26 
   27 
   28 type NameGenState = ( M.Map NameKind Int        -- next int to use
   29                     , S.Set Name                -- set of names to avoid
   30                     )
   31 
   32 type NameKind = Text
   33 
   34 newtype NameGenM m a = NameGenM (StateT NameGenState m a)
   35     deriving ( Functor, Applicative, Monad
   36              , MonadUserError
   37              , MonadLog
   38              , MonadTrans
   39              , MonadState NameGenState
   40              , MonadIO
   41              )
   42 instance (MonadFail m) => MonadFail (NameGenM m) where
   43     fail = lift . fail
   44 
   45 
   46 instance (Functor m, Applicative m, MonadFail m) => MonadFailDoc (NameGenM m) where
   47     failDoc = lift . fail . show
   48 class (Functor m, Applicative m, Monad m) => NameGen m where
   49     nextName :: NameKind -> m Name
   50     exportNameGenState :: m [(NameKind, Int)]
   51     importNameGenState :: [(NameKind, Int)] -> m ()
   52 
   53 instance NameGen m => NameGen (StateT st m) where
   54     nextName = lift . nextName
   55     exportNameGenState = lift exportNameGenState
   56     importNameGenState = lift . importNameGenState
   57 
   58 instance (NameGen m, Monoid w) => NameGen (WriterT w m) where
   59     nextName = lift . nextName
   60     exportNameGenState = lift exportNameGenState
   61     importNameGenState = lift . importNameGenState
   62 
   63 instance NameGen m => NameGen (ReaderT r m) where
   64     nextName = lift . nextName
   65     exportNameGenState = lift exportNameGenState
   66     importNameGenState = lift . importNameGenState
   67 
   68 instance NameGen m => NameGen (IdentityT m) where
   69     nextName = lift . nextName
   70     exportNameGenState = lift exportNameGenState
   71     importNameGenState = lift . importNameGenState
   72 
   73 instance NameGen m => NameGen (ExceptT m) where
   74     nextName = lift . nextName
   75     exportNameGenState = lift exportNameGenState
   76     importNameGenState = lift . importNameGenState
   77 
   78 instance NameGen m => NameGen (MaybeT m) where
   79     nextName = lift . nextName
   80     exportNameGenState = lift exportNameGenState
   81     importNameGenState = lift . importNameGenState
   82 
   83 instance NameGen m => NameGen (Pipes.Proxy a b c d m) where
   84     nextName = lift . nextName
   85     exportNameGenState = lift exportNameGenState
   86     importNameGenState = lift . importNameGenState
   87 
   88 instance (Functor m, MonadFail m) => NameGen (NameGenM m) where
   89     nextName k = do
   90         mi <- gets (M.lookup k . fst)
   91         out <- case mi of
   92             Nothing -> do
   93                 modify $ \(st, avoid) -> (M.insert k 2 st, avoid)
   94                 return $ MachineName k 1 []
   95             Just !i -> do
   96                 modify $ \(st, avoid) -> (M.insert k (i + 1) st, avoid)
   97                 return $ MachineName k i []
   98         avoid <- gets snd
   99         if out `S.member` avoid
  100             then nextName k
  101             else return out
  102     exportNameGenState = gets (M.toList . fst)
  103     importNameGenState st = modify $ \(_, avoid) -> (M.fromList st, avoid)
  104 
  105 instance NameGen (Either Doc) where
  106     nextName _ = failDoc "nextName{Either Doc}"
  107     exportNameGenState = failDoc "exportNameGenState{Either Doc}"
  108     importNameGenState _ = failDoc "importNameGenState{Either Doc}"
  109 
  110 instance NameGen Identity where
  111     nextName _ = failDoc "nextName{Identity}"
  112     exportNameGenState = failDoc "exportNameGenState{Identity}"
  113     importNameGenState _ = failDoc "importNameGenState{Identity}"
  114 
  115 runNameGen :: (MonadFailDoc m, Data x) => x -> NameGenM m a -> m a
  116 runNameGen avoid (NameGenM comp) =
  117     let initState = (M.empty, S.fromList (universeBi avoid))
  118      in evalStateT comp initState