never executed always true always false
    1 {-|
    2 Module: Flaw.Script
    3 Description: Scripting in Haskell.
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE GADTs, ViewPatterns #-}
    8 
    9 module Flaw.Script
   10   ( Interpreter()
   11   , newInterpreter
   12   , interpret
   13   , I.InterpreterError(..)
   14   ) where
   15 
   16 import Control.Concurrent.MVar
   17 import Control.Concurrent.STM
   18 import Control.Monad
   19 import Control.Monad.Catch
   20 import qualified Data.Text as T
   21 import Data.Typeable
   22 import qualified Language.Haskell.Interpreter as I
   23 
   24 import Flaw.Book
   25 import Flaw.Flow
   26 
   27 newtype Interpreter = Interpreter
   28   { interpreterTaskQueue :: TQueue Task
   29   }
   30 
   31 data Task where
   32   Task :: Typeable a =>
   33     { taskModules :: [T.Text]
   34     , taskExpression :: !T.Text
   35     , taskResultVar :: {-# UNPACK #-} !(TMVar (Either I.InterpreterError a))
   36     } -> Task
   37 
   38 newInterpreter :: [T.Text] -> IO (Interpreter, IO ())
   39 newInterpreter (map T.unpack -> searchPaths) = withSpecialBook $ \bk -> do
   40   taskQueue <- newTQueueIO
   41   activeVar <- newTVarIO True
   42   closedVar <- newEmptyMVar
   43 
   44   book bk $ forkFlow $ flip finally (putMVar closedVar ()) $ void $ I.runInterpreter $ do
   45     -- extensions set once, since they are not reset with `reset`
   46     I.set
   47       [ I.languageExtensions I.:= defaultExtensions
   48       , I.searchPath I.:= searchPaths
   49       ]
   50 
   51     let
   52       step = do
   53         -- wait for task
   54         maybeTask <- I.liftIO $ atomically $ let
   55           getTask = Just <$> readTQueue taskQueue
   56           getUnactive = do
   57             active <- readTVar activeVar
   58             when active retry
   59             return Nothing
   60           in getTask `orElse` getUnactive
   61 
   62         case maybeTask of
   63           -- if there's task
   64           Just Task
   65             { taskModules = map T.unpack -> modules
   66             , taskExpression = T.unpack -> expression
   67             , taskResultVar = resultVar
   68             } -> do
   69             -- handle task
   70             handle (I.liftIO . atomically . putTMVar resultVar . Left) $ do
   71               -- load modules
   72               I.loadModules modules
   73               I.setTopLevelModules modules
   74               let
   75                 run :: (I.MonadInterpreter m, Typeable a) => TMVar (Either I.InterpreterError a) -> a -> m a
   76                 run _ witness = I.interpret expression witness
   77               I.liftIO . atomically . putTMVar resultVar . Right =<< run resultVar undefined
   78             -- repeat
   79             step
   80           -- otherwise we're shutting down
   81           Nothing -> return ()
   82       in step
   83 
   84   -- graceful shutdown
   85   book bk $ return ((), do
   86     atomically $ writeTVar activeVar False
   87     takeMVar closedVar
   88     )
   89 
   90   return Interpreter
   91     { interpreterTaskQueue = taskQueue
   92     }
   93 
   94 interpret :: Typeable a => Interpreter -> [T.Text] -> T.Text -> IO a
   95 interpret Interpreter
   96   { interpreterTaskQueue = taskQueue
   97   } modules expression = do
   98   resultVar <- newEmptyTMVarIO
   99   atomically $ do
  100     writeTQueue taskQueue Task
  101       { taskModules = modules
  102       , taskExpression = expression
  103       , taskResultVar = resultVar
  104       }
  105   eitherResult <- atomically $ takeTMVar resultVar
  106   case eitherResult of
  107     Left e -> throwM e
  108     Right result -> return result
  109 
  110 -- | Extensions considered harmless and useful to be enabled automatically.
  111 defaultExtensions :: [I.Extension]
  112 defaultExtensions =
  113   [
  114   -- , I.OverlappingInstances -- deprecated
  115   -- , I.UndecidableInstances -- dangerous
  116   -- , I.IncoherentInstances -- deprecated
  117   -- , I.DoRec -- ?
  118     I.RecursiveDo -- harmless
  119   , I.ParallelListComp -- harmless
  120   , I.MultiParamTypeClasses -- needed
  121   , I.NoMonomorphismRestriction -- useful in scripts
  122   , I.FunctionalDependencies -- needed
  123   -- , I.Rank2Types -- obsolete, replaced with RankNTypes
  124   , I.RankNTypes -- needed
  125   -- , I.PolymorphicComponents -- obsolete, replaced with RankNTypes
  126   , I.ExistentialQuantification -- needed
  127   -- , I.ScopedTypeVariables -- usually unexpected
  128   , I.PatternSignatures -- needed
  129   , I.ImplicitParams -- harmless
  130   , I.FlexibleContexts -- needed
  131   , I.FlexibleInstances -- needed
  132   , I.EmptyDataDecls -- needed
  133   , I.NoCPP -- not sure, try to refrain from for now
  134   , I.KindSignatures -- harmless, also implied by TypeFamilies
  135   , I.BangPatterns -- harmless
  136   , I.TypeSynonymInstances -- implied by FlexibleInstances
  137   , I.TemplateHaskell -- needed
  138   , I.NoForeignFunctionInterface -- not needed in scripts
  139   , I.Arrows -- harmless
  140   , I.Generics -- ?
  141   -- , I.ImplicitPrelude -- enabled by default
  142   , I.NamedFieldPuns -- harmless
  143   , I.PatternGuards -- harmless
  144   , I.GeneralizedNewtypeDeriving -- needed
  145   -- , I.ExtensibleRecords -- ?
  146   -- , I.RestrictedTypeSynonyms -- ?
  147   -- , I.HereDocuments -- ?
  148   , I.NoMagicHash -- not needed
  149   , I.TypeFamilies -- needed
  150   , I.StandaloneDeriving -- needed
  151   , I.UnicodeSyntax -- harmless
  152   -- , I.UnliftedFFITypes -- FFI is disabled
  153   -- , I.InterruptibleFFI -- FFI is disabled
  154   -- , I.CApiFFI -- FFI is disabled
  155   , I.NoLiberalTypeSynonyms -- dangerous
  156   -- , I.TypeOperators -- not needed
  157   , I.RecordWildCards -- harmless
  158   -- , I.RecordPuns -- ?
  159   -- , I.DisambiguateRecordFields -- implied by DuplicateRecordFields
  160   -- , I.TraditionalRecordSyntax -- enabled by default
  161   , I.OverloadedStrings -- needed
  162   , I.GADTs -- needed
  163   -- , I.GADTSyntax -- implied by GADTs
  164   -- , I.MonoPatBinds -- ?
  165   -- , I.RelaxedPolyRec -- fed by ScopedTypeVariables
  166   -- , I.ExtendedDefaultRules -- ?
  167   -- , I.UnboxedTuples -- not needed
  168   , I.DeriveDataTypeable -- needed
  169   , I.DeriveGeneric -- needed
  170   , I.DefaultSignatures -- needed
  171   , I.InstanceSigs -- harmless
  172   -- , I.ConstrainedClassMethods -- implied by MultiParamTypeClasses
  173   -- , I.PackageImports -- generally not recommended
  174   -- , I.ImpredicativeTypes -- dangerous
  175   -- , I.NewQualifiedOperators -- ?
  176   -- , I.PostfixOperators -- seem to be harmless, but surprising
  177   , I.QuasiQuotes -- needed
  178   , I.TransformListComp -- harmless
  179   , I.MonadComprehensions -- harmless
  180   , I.ViewPatterns -- needed
  181   -- , I.XmlSyntax -- ?
  182   -- , I.RegularPatterns -- ?
  183   , I.TupleSections -- harmless
  184   -- , I.GHCForeignImportPrim -- ?
  185   -- , I.NPlusKPatterns -- ?
  186   -- , I.DoAndIfThenElse -- ?
  187   , I.MultiWayIf -- harmless
  188   , I.LambdaCase -- harmless
  189   , I.NoRebindableSyntax -- dangerous
  190   , I.ExplicitForAll -- harmless
  191   -- , I.DatatypeContexts -- deprecated
  192   -- , I.MonoLocalBinds -- implied by GADTs, TypeFamilies
  193   -- , I.DeriveFunctor -- not needed?
  194   -- , I.DeriveTraversable -- not needed?
  195   -- , I.DeriveFoldable -- not needed
  196   -- , I.NondecreasingIndentation -- ?
  197   -- , I.SafeImports -- ?
  198   -- , I.Safe -- not declaring safety
  199   -- , I.Trustworthy -- not declaring safety
  200   -- , I.Unsafe -- not declaring safety
  201   , I.ConstraintKinds -- needed
  202   -- , I.PolyKinds -- no kind stuff yet
  203   -- , I.DataKinds -- no kind stuff yet
  204   -- , I.ParallelArrays -- ?
  205   , I.RoleAnnotations -- harmless
  206   , I.OverloadedLists -- needed
  207   , I.EmptyCase -- harmless
  208   -- , I.AutoDeriveTypeable -- ?
  209   , I.NegativeLiterals -- useful
  210   , I.BinaryLiterals -- harmless
  211   , I.NumDecimals -- harmless
  212   -- , I.NullaryTypeClasses -- replaced by MultiParamTypeClasses
  213   -- , I.ExplicitNamespaces -- implied by TypeFamilies
  214   -- , I.AllowAmbiguousTypes -- dangerous
  215   -- , I.JavaScriptFFI -- GHCJS only
  216   , I.PatternSynonyms -- needed
  217   , I.PartialTypeSignatures -- useful in scripts
  218   , I.NamedWildCards -- harmless
  219   -- , I.DeriveAnyClass -- dangerous
  220   -- , I.DeriveLift -- not needed?
  221   , I.StaticPointers -- harmless
  222   -- , I.StrictData -- dangerous
  223   -- , I.Strict -- dangerous
  224   -- , I.ApplicativeDo -- dangerous
  225   , I.DuplicateRecordFields -- useful
  226   , I.TypeApplications -- harmless
  227   , I.TypeInType -- no kind stuff yet
  228   -- , I.UndecidableSuperClasses -- dangerous
  229   , I.MonadFailDesugaring -- needed to check that it will work with future GHC versions
  230   -- , I.TemplateHaskellQuotes -- implied by TemplateHaskell
  231   -- , I.OverloadedLabels -- harmless, but not needed
  232   ]