Commit 62b6c556 authored by Andrew Gibiansky's avatar Andrew Gibiansky

Fix formatting with newer hindent

parent ad66ac86
import Distribution.Simple import Distribution.Simple
main = defaultMain main = defaultMain
import Distribution.Simple import Distribution.Simple
import System.Cmd import System.Cmd
main = defaultMainWithHooks simpleUserHooks{ main = defaultMainWithHooks
preConf = \args confFlags -> do simpleUserHooks { preConf = \args confFlags -> do
system "./build-parser.sh" system "./build-parser.sh"
preConf simpleUserHooks args confFlags preConf simpleUserHooks args confFlags }
}
import Distribution.Simple import Distribution.Simple
main = defaultMain main = defaultMain
import Distribution.Simple import Distribution.Simple
main = defaultMain main = defaultMain
import Distribution.Simple import Distribution.Simple
main = defaultMain main = defaultMain
import Distribution.Simple import Distribution.Simple
main = defaultMain main = defaultMain
import Distribution.Simple import Distribution.Simple
main = defaultMain main = defaultMain
import Distribution.Simple import Distribution.Simple
main = defaultMain main = defaultMain
import Distribution.Simple import Distribution.Simple
main = defaultMain main = defaultMain
import Distribution.Simple import Distribution.Simple
main = defaultMain main = defaultMain
import Distribution.Simple import Distribution.Simple
main = defaultMain main = defaultMain
import Distribution.Simple import Distribution.Simple
main = defaultMain main = defaultMain
import Distribution.Simple import Distribution.Simple
main = defaultMain main = defaultMain
import Distribution.Simple import Distribution.Simple
main = defaultMain main = defaultMain
import Distribution.Simple import Distribution.Simple
main = defaultMain main = defaultMain
...@@ -4,14 +4,15 @@ ...@@ -4,14 +4,15 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
module IHaskell.Display.Widgets.Common where module IHaskell.Display.Widgets.Common where
import Data.Aeson import Data.Aeson
import Data.Aeson.Types (emptyObject) import Data.Aeson.Types (emptyObject)
import Data.Text (pack, Text) import Data.Text (pack, Text)
import IHaskell.Display (IHaskellWidget) import IHaskell.Display (IHaskellWidget)
import IHaskell.Eval.Widgets (widgetSendClose) import IHaskell.Eval.Widgets (widgetSendClose)
import qualified IHaskell.Display.Widgets.Singletons as S import qualified IHaskell.Display.Widgets.Singletons as S
...@@ -91,7 +92,8 @@ pattern SelectedIndex = S.SSelectedIndex ...@@ -91,7 +92,8 @@ pattern SelectedIndex = S.SSelectedIndex
closeWidget :: IHaskellWidget w => w -> IO () closeWidget :: IHaskellWidget w => w -> IO ()
closeWidget w = widgetSendClose w emptyObject closeWidget w = widgetSendClose w emptyObject
newtype StrInt = StrInt Integer deriving (Num, Ord, Eq, Enum) newtype StrInt = StrInt Integer
deriving (Num, Ord, Eq, Enum)
instance ToJSON StrInt where instance ToJSON StrInt where
toJSON (StrInt x) = toJSON . pack $ show x toJSON (StrInt x) = toJSON . pack $ show x
...@@ -205,7 +207,8 @@ instance ToJSON ImageFormatValue where ...@@ -205,7 +207,8 @@ instance ToJSON ImageFormatValue where
toJSON = toJSON . pack . show toJSON = toJSON . pack . show
-- | Options for selection widgets. -- | Options for selection widgets.
data SelectionOptions = OptionLabels [Text] | OptionDict [(Text, Text)] data SelectionOptions = OptionLabels [Text]
| OptionDict [(Text, Text)]
-- | Orientation values. -- | Orientation values.
data OrientationValue = HorizontalOrientation data OrientationValue = HorizontalOrientation
......
...@@ -10,18 +10,13 @@ ...@@ -10,18 +10,13 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
module IHaskell.Display.Widgets.Interactive ( module IHaskell.Display.Widgets.Interactive (interactive, uncurryHList, Rec(..), Argument(..)) where
interactive,
uncurryHList,
Rec (..),
Argument (..),
) where
import Data.Text import Data.Text
import Data.Proxy import Data.Proxy
import Data.Vinyl.Core import Data.Vinyl.Core
import Data.Vinyl.Functor (Identity (..), Const (..)) import Data.Vinyl.Functor (Identity(..), Const(..))
import Data.Vinyl.Derived (HList) import Data.Vinyl.Derived (HList)
import Data.Vinyl.Lens (type ()) import Data.Vinyl.Lens (type ())
import Data.Vinyl.TypeLevel (RecAll) import Data.Vinyl.TypeLevel (RecAll)
...@@ -39,35 +34,49 @@ import IHaskell.Display.Widgets.Int.BoundedInt.IntSlider ...@@ -39,35 +34,49 @@ import IHaskell.Display.Widgets.Int.BoundedInt.IntSlider
import IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider import IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider
import IHaskell.Display.Widgets.Output import IHaskell.Display.Widgets.Output
data WidgetConf a where data WidgetConf a where
WidgetConf :: (RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs, FromWidget a) WidgetConf ::
=> WrappedWidget (SuitableWidget a) (SuitableHandler a) (SuitableField a) a (RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs,
-> WidgetConf a FromWidget a) =>
WrappedWidget (SuitableWidget a) (SuitableHandler a)
newtype WrappedConstructor a = WrappedConstructor { (SuitableField a)
wrappedConstructor :: IO (IPythonWidget (SuitableWidget a)) a
} -> WidgetConf a
newtype WrappedConstructor a =
WrappedConstructor
{ wrappedConstructor :: IO (IPythonWidget (SuitableWidget a)) }
type family WithTypes (ts :: [*]) (r :: *) :: * where type family WithTypes (ts :: [*]) (r :: *) :: * where
WithTypes '[] r = r WithTypes '[] r = r
WithTypes (x ': xs) r = (x -> WithTypes xs r) WithTypes (x ': xs) r = (x -> WithTypes xs r)
uncurryHList :: WithTypes ts r -> HList ts -> r uncurryHList :: WithTypes ts r -> HList ts -> r
uncurryHList f RNil = f uncurryHList f RNil = f
uncurryHList f (Identity x :& xs) = uncurryHList (f x) xs uncurryHList f (Identity x :& xs) = uncurryHList (f x) xs
-- Consistent type variables are required to make things play nicely with vinyl -- Consistent type variables are required to make things play nicely with vinyl
data Constructor a where data Constructor a where
Constructor :: RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs Constructor ::
=> IO (IPythonWidget (SuitableWidget a)) -> Constructor a RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs =>
IO (IPythonWidget (SuitableWidget a)) -> Constructor a
newtype Getter a = Getter (IPythonWidget (SuitableWidget a) -> IO a) newtype Getter a = Getter (IPythonWidget (SuitableWidget a) -> IO a)
newtype EventSetter a = EventSetter (IPythonWidget (SuitableWidget a) -> IO () -> IO ()) newtype EventSetter a = EventSetter (IPythonWidget (SuitableWidget a) -> IO () -> IO ())
newtype Initializer a = Initializer (IPythonWidget (SuitableWidget a) -> Argument a -> IO ()) newtype Initializer a = Initializer (IPythonWidget (SuitableWidget a) -> Argument a -> IO ())
newtype Trigger a = Trigger (IPythonWidget (SuitableWidget a) -> IO ()) newtype Trigger a = Trigger (IPythonWidget (SuitableWidget a) -> IO ())
data RequiredWidget a where data RequiredWidget a where
RequiredWidget :: RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs RequiredWidget ::
=> IPythonWidget (SuitableWidget a) RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs =>
-> RequiredWidget a IPythonWidget (SuitableWidget a) -> RequiredWidget a
-- Zipping vinyl records in various ways -- Zipping vinyl records in various ways
applyGetters :: Rec Getter ts -> Rec RequiredWidget ts -> IO (HList ts) applyGetters :: Rec Getter ts -> Rec RequiredWidget ts -> IO (HList ts)
...@@ -108,8 +117,9 @@ createWidget :: Constructor a -> IO (RequiredWidget a) ...@@ -108,8 +117,9 @@ createWidget :: Constructor a -> IO (RequiredWidget a)
createWidget (Constructor con) = fmap RequiredWidget con createWidget (Constructor con) = fmap RequiredWidget con
mkChildren :: Rec RequiredWidget a -> [ChildWidget] mkChildren :: Rec RequiredWidget a -> [ChildWidget]
mkChildren widgets = let childRecord = rmap (\(RequiredWidget w) -> Const (ChildWidget w)) widgets mkChildren widgets =
in recordToList childRecord let childRecord = rmap (\(RequiredWidget w) -> Const (ChildWidget w)) widgets
in recordToList childRecord
class MakeConfs (ts :: [*]) where class MakeConfs (ts :: [*]) where
mkConfs :: proxy ts -> Rec WidgetConf ts mkConfs :: proxy ts -> Rec WidgetConf ts
...@@ -122,13 +132,13 @@ instance (FromWidget t, MakeConfs ts) => MakeConfs (t ': ts) where ...@@ -122,13 +132,13 @@ instance (FromWidget t, MakeConfs ts) => MakeConfs (t ': ts) where
interactive :: (IHaskellDisplay r, MakeConfs ts) interactive :: (IHaskellDisplay r, MakeConfs ts)
=> (HList ts -> r) -> Rec Argument ts -> IO FlexBox => (HList ts -> r) -> Rec Argument ts -> IO FlexBox
interactive func = let confs = mkConfs Proxy interactive func =
in liftToWidgets func confs let confs = mkConfs Proxy
in liftToWidgets func confs
-- | Transform a function (HList ts -> r) to one which: -- | Transform a function (HList ts -> r) to one which: 1) Uses widgets to accept the arguments 2)
-- 1) Uses widgets to accept the arguments -- Accepts initial values for the arguments 3) Creates a compound FlexBox widget with an embedded
-- 2) Accepts initial values for the arguments -- OutputWidget for display
-- 3) Creates a compound FlexBox widget with an embedded OutputWidget for display
liftToWidgets :: IHaskellDisplay r liftToWidgets :: IHaskellDisplay r
=> (HList ts -> r) -> Rec WidgetConf ts -> Rec Argument ts -> IO FlexBox => (HList ts -> r) -> Rec WidgetConf ts -> Rec Argument ts -> IO FlexBox
liftToWidgets func rc initvals = do liftToWidgets func rc initvals = do
...@@ -154,7 +164,6 @@ liftToWidgets func rc initvals = do ...@@ -154,7 +164,6 @@ liftToWidgets func rc initvals = do
-- Set initial values for all widgets -- Set initial values for all widgets
setInitialValues initializers widgets initvals setInitialValues initializers widgets initvals
-- applyValueSetters valueSetters widgets $ getList defvals -- applyValueSetters valueSetters widgets $ getList defvals
setField out Width 500 setField out Width 500
setField bx Orientation VerticalOrientation setField bx Orientation VerticalOrientation
...@@ -164,10 +173,14 @@ liftToWidgets func rc initvals = do ...@@ -164,10 +173,14 @@ liftToWidgets func rc initvals = do
return bx return bx
data WrappedWidget w h f a where data WrappedWidget w h f a where
WrappedWidget :: (FieldType h ~ IO (), FieldType f ~ a, h WidgetFields w, f WidgetFields w, WrappedWidget ::
ToPairs (Attr h), IHaskellWidget (IPythonWidget w), ToPairs (Attr f)) (FieldType h ~ IO (), FieldType f ~ a, h WidgetFields w,
=> IO (IPythonWidget w) -> S.SField h -> S.SField f -> WrappedWidget w h f a f WidgetFields w, ToPairs (Attr h),
IHaskellWidget (IPythonWidget w), ToPairs (Attr f)) =>
IO (IPythonWidget w) ->
S.SField h -> S.SField f -> WrappedWidget w h f a
construct :: WrappedWidget w h f a -> IO (IPythonWidget w) construct :: WrappedWidget w h f a -> IO (IPythonWidget w)
construct (WrappedWidget cons _ _) = cons construct (WrappedWidget cons _ _) = cons
...@@ -212,7 +225,8 @@ instance FromWidget Integer where ...@@ -212,7 +225,8 @@ instance FromWidget Integer where
type SuitableWidget Integer = IntSliderType type SuitableWidget Integer = IntSliderType
type SuitableHandler Integer = S.ChangeHandler type SuitableHandler Integer = S.ChangeHandler
type SuitableField Integer = S.IntValue type SuitableField Integer = S.IntValue
data Argument Integer = IntVal Integer | IntRange (Integer, Integer, Integer) data Argument Integer = IntVal Integer
| IntRange (Integer, Integer, Integer)
wrapped = WrappedWidget mkIntSlider ChangeHandler IntValue wrapped = WrappedWidget mkIntSlider ChangeHandler IntValue
initializer w (IntVal int) = setField w IntValue int initializer w (IntVal int) = setField w IntValue int
initializer w (IntRange (v, l, u)) = do initializer w (IntRange (v, l, u)) = do
...@@ -224,7 +238,8 @@ instance FromWidget Double where ...@@ -224,7 +238,8 @@ instance FromWidget Double where
type SuitableWidget Double = FloatSliderType type SuitableWidget Double = FloatSliderType
type SuitableHandler Double = S.ChangeHandler type SuitableHandler Double = S.ChangeHandler
type SuitableField Double = S.FloatValue type SuitableField Double = S.FloatValue
data Argument Double = FloatVal Double | FloatRange (Double, Double, Double) data Argument Double = FloatVal Double
| FloatRange (Double, Double, Double)
wrapped = WrappedWidget mkFloatSlider ChangeHandler FloatValue wrapped = WrappedWidget mkFloatSlider ChangeHandler FloatValue
initializer w (FloatVal d) = setField w FloatValue d initializer w (FloatVal d) = setField w FloatValue d
initializer w (FloatRange (v, l, u)) = do initializer w (FloatRange (v, l, u)) = do
......
...@@ -5,12 +5,15 @@ ...@@ -5,12 +5,15 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
module IHaskell.Display.Widgets.Singletons where module IHaskell.Display.Widgets.Singletons where
import Data.Singletons.TH import Data.Singletons.TH
-- Widget properties -- Widget properties
singletons [d| singletons
[d|
data Field = ViewModule data Field = ViewModule
| ViewName | ViewName
| MsgThrottle | MsgThrottle
...@@ -83,4 +86,4 @@ singletons [d| ...@@ -83,4 +86,4 @@ singletons [d|
| Titles | Titles
| SelectedIndex | SelectedIndex
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
|] |]
...@@ -136,6 +136,7 @@ requiredGlobalImports = ...@@ -136,6 +136,7 @@ requiredGlobalImports =
, "import qualified System.IO as IHaskellSysIO" , "import qualified System.IO as IHaskellSysIO"
, "import qualified Language.Haskell.TH as IHaskellTH" , "import qualified Language.Haskell.TH as IHaskellTH"
] ]
ihaskellGlobalImports :: [String] ihaskellGlobalImports :: [String]
ihaskellGlobalImports = ihaskellGlobalImports =
[ "import IHaskell.Display()" [ "import IHaskell.Display()"
...@@ -146,7 +147,8 @@ ihaskellGlobalImports = ...@@ -146,7 +147,8 @@ ihaskellGlobalImports =
-- | Run an interpreting action. This is effectively runGhc with initialization and importing. First -- | Run an interpreting action. This is effectively runGhc with initialization and importing. First
-- argument indicates whether `stdin` is handled specially, which cannot be done in a testing -- argument indicates whether `stdin` is handled specially, which cannot be done in a testing
-- environment. The argument passed to the action indicates whether Haskell support libraries are available. -- environment. The argument passed to the action indicates whether Haskell support libraries are
-- available.
interpret :: String -> Bool -> (Bool -> Interpreter a) -> IO a interpret :: String -> Bool -> (Bool -> Interpreter a) -> IO a
interpret libdir allowedStdin action = runGhc (Just libdir) $ do interpret libdir allowedStdin action = runGhc (Just libdir) $ do
-- If we're in a sandbox, add the relevant package database -- If we're in a sandbox, add the relevant package database
...@@ -177,8 +179,8 @@ packageIdString' dflags = packageKeyPackageIdString dflags ...@@ -177,8 +179,8 @@ packageIdString' dflags = packageKeyPackageIdString dflags
#else #else
packageIdString' dflags = packageIdString packageIdString' dflags = packageIdString
#endif #endif
-- | Initialize our GHC session with imports and a value for 'it'. -- | Initialize our GHC session with imports and a value for 'it'. Return whether the IHaskell
-- Return whether the IHaskell support libraries are available. -- support libraries are available.
initializeImports :: Interpreter Bool initializeImports :: Interpreter Bool
initializeImports = do initializeImports = do
-- Load packages that start with ihaskell-*, aren't just IHaskell, and depend directly on the right -- Load packages that start with ihaskell-*, aren't just IHaskell, and depend directly on the right
...@@ -202,9 +204,9 @@ initializeImports = do ...@@ -202,9 +204,9 @@ initializeImports = do
guard (iHaskellPkgName `isPrefixOf` idString) guard (iHaskellPkgName `isPrefixOf` idString)
displayPkgs = [pkgName | pkgName <- packageNames displayPkgs = [pkgName | pkgName <- packageNames
, Just (x:_) <- [stripPrefix initStr pkgName] , Just (x:_) <- [stripPrefix initStr pkgName]
, pkgName `notElem` broken , pkgName `notElem` broken
, isAlpha x] , isAlpha x]
hasIHaskellPackage = not $ null $ filter (== iHaskellPkgName) packageNames hasIHaskellPackage = not $ null $ filter (== iHaskellPkgName) packageNames
...@@ -228,8 +230,8 @@ initializeImports = do ...@@ -228,8 +230,8 @@ initializeImports = do
-- Import modules. -- Import modules.
imports <- mapM parseImportDecl $ requiredGlobalImports ++ if hasIHaskellPackage imports <- mapM parseImportDecl $ requiredGlobalImports ++ if hasIHaskellPackage
then ihaskellGlobalImports ++ displayImports then ihaskellGlobalImports ++ displayImports
else [] else []
setContext $ map IIDecl $ implicitPrelude : imports setContext $ map IIDecl $ implicitPrelude : imports
-- Set -fcontext-stack to 100 (default in ghc-7.10). ghc-7.8 uses 20, which is too small. -- Set -fcontext-stack to 100 (default in ghc-7.10). ghc-7.8 uses 20, which is too small.
...@@ -318,8 +320,8 @@ evaluate kernelState code output widgetHandler = do ...@@ -318,8 +320,8 @@ evaluate kernelState code output widgetHandler = do
-- Get displayed channel outputs. Merge them with normal display outputs. -- Get displayed channel outputs. Merge them with normal display outputs.
dispsMay <- if supportLibrariesAvailable state dispsMay <- if supportLibrariesAvailable state
then extractValue "IHaskell.Display.displayFromChan" >>= liftIO then extractValue "IHaskell.Display.displayFromChan" >>= liftIO
else return Nothing else return Nothing
let result = let result =
case dispsMay of case dispsMay of
Nothing -> evalResult evalOut Nothing -> evalResult evalOut
...@@ -336,8 +338,8 @@ evaluate kernelState code output widgetHandler = do ...@@ -336,8 +338,8 @@ evaluate kernelState code output widgetHandler = do
-- Handle the widget messages -- Handle the widget messages
newState <- if supportLibrariesAvailable state newState <- if supportLibrariesAvailable state
then flushWidgetMessages tempState tempMsgs widgetHandler then flushWidgetMessages tempState tempMsgs widgetHandler
else return tempState else return tempState
case evalStatus evalOut of case evalStatus evalOut of
Success -> runUntilFailure newState rest Success -> runUntilFailure newState rest
......
...@@ -44,21 +44,16 @@ except: ...@@ -44,21 +44,16 @@ except:
# Find all the source files # Find all the source files
sources = [] sources = []
widget_dir = "ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets"
for source_dir in ["src", "ipython-kernel", "ihaskell-display"]: for source_dir in ["src", "ipython-kernel", "ihaskell-display"]:
for root, dirnames, filenames in os.walk(source_dir): for root, dirnames, filenames in os.walk(source_dir):
# Skip cabal dist directories # Skip cabal dist directories
if "dist" in root: if "dist" in root:
continue continue
# Ignore IHaskellPrelude.hs, it uses CPP in weird places
ignored_files = ["IHaskellPrelude.hs"]
for filename in filenames: for filename in filenames:
if "ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets" in root:
# Ignoring files from ihaskell-widgets
# They cause issues with hindent, due to promoted types
ignored_files = ["Types.hs", "Common.hs", "Singletons.hs", "Interactive.hs"]
else:
# Take Haskell files, but ignore the Cabal Setup.hs
# Also ignore IHaskellPrelude.hs, it uses CPP in weird places
ignored_files = ["Setup.hs", "IHaskellPrelude.hs", "Evaluate.hs"]
if filename.endswith(".hs") and filename not in ignored_files: if filename.endswith(".hs") and filename not in ignored_files:
sources.append(os.path.join(root, filename)) sources.append(os.path.join(root, filename))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment