module NLP.GenI.Flag where
import Data.List (find)
import Data.Maybe (catMaybes, fromJust, fromMaybe)
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Typeable
import NLP.GenI.FeatureStructure (Flist)
import NLP.GenI.GeniVal (GeniVal)
import NLP.GenI.Polarity.Types
data Optimisation = PolOpts
| AdjOpts
| Polarised
| NoConstraints
| Guided
deriving (Show,Eq,Typeable)
type Instruction = (FilePath, Maybe [Text])
data BuilderType = SimpleBuilder | SimpleOnePhaseBuilder
deriving (Eq, Typeable)
data GrammarType = GeniHand
| PreCompiled
| PreAnchored
deriving (Show, Eq, Typeable)
defaultGrammarType :: GrammarType
defaultGrammarType = GeniHand
getGrammarType :: [Flag] -> GrammarType
getGrammarType = fromMaybe defaultGrammarType . getFlag GrammarTypeFlg
instance Show BuilderType where
show SimpleBuilder = "simple-2p"
show SimpleOnePhaseBuilder = "simple-1p"
hasOpt :: Optimisation -> [Flag] -> Bool
hasOpt o p = maybe False (elem o) $ getFlag OptimisationsFlg p
data Flag = forall f x . (Eq f, Typeable f, Typeable x) =>
Flag (x -> f) x deriving (Typeable)
class HasFlags x where
flags :: x -> [Flag]
onFlags :: ([Flag] -> [Flag]) -> x -> x
instance HasFlags [Flag] where
flags = id
onFlags f = f
instance Eq Flag where
(Flag f1 x1) == (Flag f2 x2)
| (typeOf f1 == typeOf f2) && (typeOf x1 == typeOf x2) =
(fromJust . cast . f1 $ x1) == (f2 x2)
| otherwise = False
isFlag :: (Typeable f, Typeable x) => (x -> f) -> Flag -> Bool
isFlag f1 (Flag f2 _) = typeOf f1 == typeOf f2
hasFlag :: (Typeable f, Typeable x, HasFlags flags) => (x -> f) -> flags -> Bool
hasFlag f = any (isFlag f) . flags
deleteFlag :: (Typeable f, Typeable x, HasFlags flags) => (x -> f) -> flags -> flags
deleteFlag f fs =
onFlags (const good) fs
where
good = filter innocent (flags fs)
innocent = not . isFlag f
modifyFlag :: (Eq f, Typeable f, Typeable x, HasFlags flags)
=> (x -> f)
-> (x -> x)
-> flags
-> flags
modifyFlag f m fs =
case getFlag f (flags fs) of
Nothing -> fs
Just v -> onFlags (setFlag f (m v)) fs
setFlag :: (Eq f, Typeable f, Typeable x, HasFlags flags)
=> (x -> f)
-> x
-> flags
-> flags
setFlag f v =
onFlags setf
where
setf fs = (Flag f v) : tl where tl = deleteFlag f fs
getFlag :: (Typeable f, Typeable x, HasFlags flags)
=> (x -> f)
-> flags
-> Maybe x
getFlag f fs = do (Flag _ v) <- find (isFlag f) (flags fs) ; cast v
getAllFlags :: (Typeable f, Typeable x, HasFlags flags)
=> (x -> f) -> flags -> [x]
getAllFlags f fs = catMaybes [ cast v | flg@(Flag _ v) <- flags fs, isFlag f flg ]
getListFlag :: (Typeable f, Typeable x, HasFlags flags)
=> ([x] -> f) -> flags -> [x]
getListFlag f = fromMaybe [] . getFlag f . flags
updateFlags :: (HasFlags flags)
=> flags
-> flags
-> flags
updateFlags new_ old_ =
onFlags (const updated) old_
where
updated = foldr update old new
old = flags old_
new = flags new_
update (Flag f v) fs = setFlag f v fs
newtype BatchDirFlg = BatchDirFlg FilePath deriving (Eq, Typeable)
newtype DisableGuiFlg = DisableGuiFlg () deriving (Eq, Typeable)
newtype DetectPolaritiesFlg = DetectPolaritiesFlg (Set.Set PolarityAttr) deriving (Eq, Typeable)
newtype DumpDerivationFlg = DumpDerivationFlg () deriving (Eq, Typeable)
newtype EarlyDeathFlg = EarlyDeathFlg () deriving (Eq, Typeable)
newtype FromStdinFlg = FromStdinFlg () deriving (Eq, Typeable)
newtype HelpFlg = HelpFlg () deriving (Eq, Typeable)
newtype InstructionsFileFlg = InstructionsFileFlg FilePath deriving (Eq, Typeable)
newtype LexiconFlg = LexiconFlg FilePath deriving (Eq, Typeable)
newtype MacrosFlg = MacrosFlg FilePath deriving (Eq, Typeable)
newtype TracesFlg = TracesFlg FilePath deriving (Eq, Typeable)
newtype MaxStepsFlg = MaxStepsFlg Integer deriving (Eq, Typeable)
newtype MaxResultsFlg = MaxResultsFlg Integer deriving (Eq, Typeable)
newtype MetricsFlg = MetricsFlg [String] deriving (Eq, Typeable)
newtype MorphCmdFlg = MorphCmdFlg String deriving (Eq, Typeable)
newtype MorphInfoFlg = MorphInfoFlg FilePath deriving (Eq, Typeable)
newtype OptimisationsFlg = OptimisationsFlg [Optimisation] deriving (Eq, Typeable)
newtype OutputFileFlg = OutputFileFlg String deriving (Eq, Typeable)
newtype PartialFlg = PartialFlg () deriving (Eq, Typeable)
newtype RankingConstraintsFlg = RankingConstraintsFlg FilePath deriving (Eq, Typeable)
newtype RootFeatureFlg = RootFeatureFlg (Flist GeniVal) deriving (Eq, Typeable)
newtype NoLoadTestSuiteFlg = NoLoadTestSuiteFlg () deriving (Eq, Typeable)
newtype StatsFileFlg = StatsFileFlg FilePath deriving (Eq, Typeable)
newtype TestCaseFlg = TestCaseFlg Text deriving (Eq, Typeable)
newtype TestInstructionsFlg = TestInstructionsFlg [Instruction] deriving (Eq, Typeable)
newtype TestSuiteFlg = TestSuiteFlg FilePath deriving (Eq, Typeable)
newtype TimeoutFlg = TimeoutFlg Int deriving (Eq, Typeable)
newtype VerboseModeFlg = VerboseModeFlg () deriving (Eq, Typeable)
newtype VersionFlg = VersionFlg () deriving (Eq, Typeable)
newtype ViewCmdFlg = ViewCmdFlg String deriving (Eq, Typeable)
newtype BuilderFlg = BuilderFlg BuilderType deriving (Eq, Typeable)
newtype GrammarTypeFlg = GrammarTypeFlg GrammarType deriving (Eq, Typeable)
newtype WeirdFlg = WeirdFlg String deriving (Eq, Typeable)