diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Robert Fischer (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Robert Fischer nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import RFC.Prelude + +main :: IO () +main = return () diff --git a/classy-miso.cabal b/classy-miso.cabal new file mode 100644 --- /dev/null +++ b/classy-miso.cabal @@ -0,0 +1,92 @@ +name: classy-miso +version: 0.0.0.1 +description: Please see the README on Github at +homepage: https://github.com/RobertFischer/Classy-Miso#README.md +bug-reports: https://github.com/RobertFischer/Classy-Miso#README.md +author: Robert Fischer +maintainer: smokejumperit+stack@gmail.com +copyright: Robert Fischer +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +category: web +synopsis: Typeclass based support for Miso, the Tasty Web Framework for Haskell. + +source-repository head + type: git + location: https://github.com/RobertFischer/Classy-Miso + +Flag Development + Description: Turn on errors for warnings + Default: False + Manual: True + +library + hs-source-dirs: + src + build-depends: + base >= 4.7 && <5 + , miso >= 0.15.0.0 && < 0.16 + , rfc >= 0.0.0.25 && < 0.1 + , megaparsec >= 6.4.0.0 && < 7 + , lens >= 4.15.0.0 && < 5 + , network-uri >= 2.6.1.0 && < 2.7 + , containers >= 0.5.7.1 && < 0.6 + , url >= 2.1.3 && < 2.2 + if impl(ghcjs) + build-depends: aeson + , bifunctors + cpp-options: -DCLIENT -DGHCJS_BROWSER -DBROWSER + default-language: Haskell2010 + default-extensions: RebindableSyntax + , MonadFailDesugaring + , MultiParamTypeClasses + , TypeFamilies + , ExistentialQuantification + , FlexibleContexts + , FlexibleInstances + , RankNTypes + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans + ghc-options: -fno-max-relevant-binds -fprint-potential-instances -Wno-missing-monadfail-instances + ghc-options: -fno-warn-name-shadowing -fno-warn-tabs -Wall-missed-specialisations -Wnoncanonical-monad-instances + ghc-options: -Wnoncanonical-monadfail-instances -Wimplicit-prelude -Wmissing-exported-signatures -Widentities + if flag(Development) + ghc-options: -Werror -dcore-lint -dcmm-lint + exposed-modules: Miso.Classy + , Miso.Classy.App + +executable classy-miso-demo + main-is: Main.hs + hs-source-dirs: + app + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans + ghc-options: -fno-max-relevant-binds -fprint-potential-instances -Wno-missing-monadfail-instances + ghc-options: -fno-warn-name-shadowing -fno-warn-tabs -Wall-missed-specialisations -Wnoncanonical-monad-instances + ghc-options: -Wnoncanonical-monadfail-instances -Wimplicit-prelude -Wmissing-exported-signatures -Widentities + if flag(Development) + ghc-options: -Werror -dcore-lint -dcmm-lint + build-depends: + base >=4.7 && <5 + , classy-miso + , miso + , rfc + default-language: Haskell2010 + default-extensions: RebindableSyntax + , MonadFailDesugaring + , MultiParamTypeClasses + , TypeFamilies + , RankNTypes + +test-suite ghcjs-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , classy-miso + , miso + , rfc + default-language: Haskell2010 diff --git a/src/Miso/Classy.hs b/src/Miso/Classy.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Classy.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnicodeSyntax #-} +#if !MIN_VERSION_base(4,10,0) +{-# OPTIONS_GHC -fno-warn-deprecations #-} +#endif + +module Miso.Classy + ( Component(..) + , update' + , WrappedComponent + , wrapComponent + , mapWrappedComponent + , addSubcomponent + , WrappedAction(..) + , RouteParser + , ClassyEffect + , WrappedEffect + , ClassyTransition + , ClassySub + , ClassySink + , WrappedView + , WrappedSub + , WrappedSink + , wrapAction + , wrapSub + , routeToURI + , toRoutePath + , getCurrentURI + , parseCurrentURI + , RoutePath + , actionToSub + , actionToWrappedSub + , viewSub + , viewSubs + , viewSubBy + , viewSubsBy + , emptyView + , module Miso + , module Network.URI + , module RFC.Miso.String + ) where + +import Control.Lens hiding ( view ) +import Data.Map.Strict ( Map ) +import qualified Data.Map.Strict as Map +import Data.Typeable +import Miso hiding ( App (..), getCurrentURI ) +import qualified Miso.Html as Html +import Network.URI ( URI (..), parseURI ) +import qualified Network.URL as URL +import RFC.Miso.String +import RFC.Prelude hiding ( init ) + +-- Need the ability to compare proxies for equivalence +#if MIN_VERSION_base(4,10,0) +import Type.Reflection ( eqTypeRep ) + +eqProxy :: Proxy a -> Proxy b -> Maybe (a :~: b) +eqProxy a b = eqTypeRep (typeRep a) (typeRep b) +#else +-- | Hand-rolled and dangerous implementation of 'eqTypeRep'. +eqProxy :: (Typeable a, Typeable b) => Proxy a -> Proxy b -> Maybe (a :~: b) +eqProxy a b + | typeRep a == typeRep b = Just undefined + | otherwise = Nothing +#endif + +{-# ANN module ("HLint: ignore Use fewer imports"::String) #-} + +-- | A 'View' where we wrap up the action type as a 'WrappedAction'. +type WrappedView = View WrappedAction + +-- | An 'Effect' where we wrap up the action type as a 'WrappedAction'. +type WrappedEffect model = Effect WrappedAction model + +-- | A 'Sink' where we wrap up the action type as a 'WrappedAction'. +type WrappedSink = WrappedAction -> IO () + +-- | A 'Sub' where we wrap up the action type as a 'WrappedSub'. +type WrappedSub = WrappedSink -> IO () + +-- | Handy alias specifying the 'Effect' in terms of type families. +type ClassyEffect model = Effect (Action model) model + +-- | Handy alias specifying the 'Transition' in terms of type families. +type ClassyTransition model = Transition (Action model) model + +-- | Handy alias specifying the 'Sink' in terms of type families. +type ClassySink model = Action model -> IO () + +-- | Handy alias specifying the 'Sub' in terms of type families. +type ClassySub model = ClassySink model -> IO () + +-- | Wraps the concept of th e +class (Eq model, Typeable model, Typeable (Action model)) => Component model where + {-# MINIMAL init, view, subcomponents, (update|transition) #-} + + -- | The actions for this component, such as those returned in an 'Effect' + type Action model = action | action -> model + + -- | Defines the initial arguments that the component expects to receive. + type InitArgs model = initargs | initargs -> model + + init :: InitArgs model → IO model -- ^ Initialize the model + view :: model -> View (Action model) -- ^ Render the model into a VDOM-friendly structure + + subcomponents :: ALens' model [WrappedComponent] -- ^ Holds onto all the subcomponents + + routeParser :: model -> RouteParser -- ^ Provides a parser that defines the route for this model + routeParser _ _ = fail "Model is not a route" + {-# INLINE routeParser #-} + + -- | Implement this if you want to use the classic way to update. + update :: Action model -> model -> ClassyEffect model + update = fromTransition . transition + {-# INLINE update #-} + + -- | Implement this if you want to use the 'Transition'-based way to update. + transition :: Action model -> ClassyTransition model () + transition = toTransition . update + {-# INLINE transition #-} + + -- | Whether or not this action is really for this model. By default, we accept all actions. But, if you've + -- got multiple components of the same type, you may need to be more picky. + acceptAction :: Action model -> model -> Bool + acceptAction _ _ = True + {-# INLINE acceptAction #-} + +-- | Handy method for the common case when you can pass your args down to your subcomponents. +addSubcomponent :: (Component model, Component sub) => InitArgs model -> model -> (InitArgs model -> IO (InitArgs sub)) -> IO model +addSubcomponent parentArgs parent argPicker = addSub <$> (subArgs >>= init) + where + subArgs = argPicker parentArgs + initSubs = parent^.(cloneLens subcomponents) + addSub newSub = parent & (cloneLens subcomponents) .~ (wrapComponent newSub:initSubs) + +-- | For the component itself, and then recursively for all the subcomponents, this attempts to cast +-- the action (unwrapped from 'WrappedAction') to the relevant type for that component. +-- If that works, we calls 'update' on that component. +update' :: (Component model) => WrappedAction -> model -> WrappedEffect model +update' wrapped@(WrappedAction action) initModel = + Effect finalModel allEffects + where + (finalModel, allEffects) = (foldedModel, foldedEffects) + Effect foldedModel foldedEffects = + foldr foldImpl initEffect (initModel^.(cloneLens subcomponents)) + foldImpl (WrappedComponent (_,subcomp)) (Effect roundModel roundEffects) = + let result = update' wrapped subcomp in + let Effect wrappedModel wrappedEffects = result & + bimap + id + (\subModel -> roundModel & (cloneLens subcomponents) %~ ((:) (WrappedComponent (Proxy,subModel)))) + in + Effect wrappedModel (wrappedEffects <> roundEffects) + initEffect = + case cast action of + Nothing -> noEff initModel + Just myAction -> + if acceptAction myAction initModel then + bimap wrapAction id $ update myAction initModel + else + noEff initModel +{-# INLINABLE update' #-} + +-- | The function for processing routes from route paths. It will consume the current +-- 'RoutePath', and (if it successfully parsed), it returns the component that handles the route. +type RouteParser = forall m. MonadFail m => RoutePath -> m WrappedComponent + +-- | A wrapper around components that hides the existential quantification. +data WrappedComponent = forall child. Component child ⇒ WrappedComponent (Proxy child, child) +instance Eq WrappedComponent where + (==) (WrappedComponent left) (WrappedComponent right) = + maybe False (left ==) (cast right) + {-# INLINE (==) #-} + +-- | Smart constructor for 'WrappedComponent'. +wrapComponent :: Component child => child -> WrappedComponent +wrapComponent child = WrappedComponent (Proxy, child) +{-# INLINE wrapComponent #-} + +-- | Allows you to effectively extract the component, but note that the type of the +-- wrapped component can't escape its scope. +mapWrappedComponent :: (forall model. Component model => model -> a) -> WrappedComponent -> a +mapWrappedComponent f (WrappedComponent(_,it)) = f it +{-# INLINE mapWrappedComponent #-} + +-- | A wrapper around actions, such as those returned in an 'Effect', which +-- hides the existential quantification. +data WrappedAction = forall child. Component child => WrappedAction (Action child) + +-- | Utility function for wrapping up an action into a 'WrappedAction' +wrapAction :: Component model => Action model -> WrappedAction +wrapAction = WrappedAction +{-# INLINE wrapAction #-} + +-- | Utility method for converting an action into a 'Sub' +actionToSub :: Action model -> Sub (Action model) +actionToSub action sink = sink action +{-# INLINE actionToSub #-} + +-- | Utility function for wrapping up a 'Sub' into a 'WrappedSub' +wrapSub :: Component model => Sub (Action model) -> WrappedSub +wrapSub sub sink = sub (sink . wrapAction) +{-# INLINE wrapSub #-} + +-- | Ties together 'actionToSub' and 'wrapSub' for you, +-- so you can go all the way from an action to a 'WrappedSub'. +actionToWrappedSub :: Component model => Action model -> WrappedSub +actionToWrappedSub = wrapSub . actionToSub +{-# INLINE actionToWrappedSub #-} + +-- | A single segment of a route (a piece between slashes in the URI fragment) +type RouteSegment = StrictText + +-- | The value of the query section of a route +type RouteQuery = Map StrictText [StrictText] + +-- | The full path of the route. The third URL is the "base URI", +-- and does not necessarily contain the 'RouteSegment' and the +-- 'RouteQuery' pieces. +type RoutePath = ([RouteSegment], RouteQuery, URI) + +-- | Generates a URI from the route path by merging the 'RouteQuery' into the 'uriQuery' +-- and the '[RouteSegment]' into the 'uriFragment'. +routeToURI :: RoutePath -> URI +routeToURI (segs, qry, uri) = + uri + { uriQuery = '?':query + , uriFragment = '#':frag + } + where + encodeString :: ConvertibleStrings a String => Bool -> a -> String -- Second argument is: "Is this a query string?" + encodeString spaceToPlus = URL.encString spaceToPlus URL.ok_param . cs + query :: String + query = intercalate "&" . pairsToTerms $ Map.toList qry + pairsToTerms [] = [] + pairsToTerms ((key,[]):rest) = (encodeString True key) : pairsToTerms rest + pairsToTerms ((key,([val])):rest) = (encodeString True key <> "=" <> (encodeString True val)) : pairsToTerms rest + pairsToTerms ((key,vals):rest) = (encodeString True key <> "=" <> intercalate "," (encodeString True <$> vals)) : pairsToTerms rest + frag :: String + frag = intercalate "/" (segToPath <$> segs) + segToPath :: RouteSegment -> String + segToPath = encodeString False +{-# INLINABLE routeToURI #-} + + +-- | Parses a 'URI' into a 'RoutePath' +toRoutePath :: URI -> RoutePath +toRoutePath uri@URI{uriFragment,uriQuery} = + ( pathToSegments . parseHash $ uriFragment + , parseQuery uriQuery + , uri + ) + where + decodeString :: String -> StrictText + decodeString str = cs . fromMaybe str . URL.decString True $ str + pathToSegments :: String -> [RouteSegment] + pathToSegments "" = [] + pathToSegments ('/':rest) = pathToSegments rest + pathToSegments path = (decodeString start) : pathToSegments rest + where + (start,rest) = splitOnSlash path + splitOnSlash "" = ("","") + splitOnSlash ('/':content) = splitOnSlash content + splitOnSlash content = + case span ('/' /=) content of + ([],[]) -> ("","") + ([], _:theRest) -> splitOnSlash theRest + (theStart, []) -> (theStart, "") + (theStart, _:theRest) -> (theStart, theRest) + parseHash ('#':rest) = parseHash rest + parseHash ('!':rest) = parseHash rest + parseHash ('/':rest) = parseHash rest + parseHash hash = hash + parseQuery ('?':rest) = parseQuery rest + parseQuery query = + case URL.importParams query of + Nothing -> + Map.empty + Just pairs -> + fmap (second listify) pairs & + Map.fromListWith (++) & + Map.map sort & + Map.map (fmap cs) & + Map.mapKeys cs + listify :: String -> [String] + listify "" = [] + listify (',':val) = listify val + listify val = start : listify rest + where + (start,rest) = splitOnComma val + splitOnComma "" = ("","") + splitOnComma (',':content) = splitOnComma content + splitOnComma (' ':content) = splitOnComma content + splitOnComma content = + case span (',' /=) content of + ([], []) -> ("", "") + ([], _:theRest) -> splitOnComma theRest + (theStart, []) -> (theStart, "") + (theStart, _:theRest) -> (theStart, theRest) +{-# INLINABLE toRoutePath #-} + +-- | Retrieves the current location of the window from "window.location.href". +foreign import javascript safe "$r = (window && window.location && window.location.href) || '';" + getWindowLocationHref :: IO MisoString + +-- | Gets the current URI. +getCurrentURI :: (MonadIO m, MonadFail m) => m URI +getCurrentURI = do + href <- fromMisoString <$> liftIO getWindowLocationHref + case parseURI href of + Nothing -> fail $ "Co uld not parse URI from window.location: " <> href + Just uri -> return uri +{-# INLINE getCurrentURI #-} + +-- | Utility method to parse the current URI. +parseCurrentURI :: (MonadIO m) => m RoutePath +parseCurrentURI = toRoutePath <$> liftIO getCurrentURI +{-# INLINE parseCurrentURI #-} + +-- | View a particular subcomponent by specifying a test. For the first (leftmost) subcomponent +-- that returns 'True', we will return their view. Failing that, we return an +-- empty (but defined) view. +viewSubBy :: (Component model) => model -> (WrappedComponent -> Bool) -> WrappedView +viewSubBy parent subTest = fromMaybe emptyView . safeHead $ viewSubsBy parent subTest +{-# INLINE viewSubBy #-} + +-- | View a particular subcomponent by specifying its type. For the first (leftmost) subcomponent +-- whose type is equal to the given type, we will return their view. Failing that, we +-- return an empty (but defined) view. +viewSub :: (Component model, Component sub) => model -> Proxy sub -> WrappedView +viewSub parent subType = viewSubBy parent (wrappedComponentPxyEq subType) +{-# INLINE viewSub #-} + +-- | View subcomponents by a given test. For every subcomponent that returns 'True', we will +-- include their 'WrappedView' in the resulting list. +viewSubsBy :: (Component model) => model -> (WrappedComponent -> Bool) -> [WrappedView] +viewSubsBy parent test = + toWrappedView <$> filter test targets + where + targets = (wrapComponent parent : parent^.(cloneLens subcomponents)) + toWrappedView :: WrappedComponent -> WrappedView + toWrappedView (WrappedComponent(_,sub)) = WrappedAction <$> view sub +{-# INLINE viewSubsBy #-} + +-- | View subcomponents by specifying their type. For every subcomponent of whose type +-- is equal to the given type, we will include their 'WrappedView' in the resulting list. +viewSubs :: (Component model, Component sub) => model -> Proxy sub -> [WrappedView] +viewSubs parent subType = viewSubsBy parent (wrappedComponentPxyEq subType) +{-# INLINE viewSubs #-} + +-- | Test that a 'WrappedComponent' is equal to a given type. +wrappedComponentPxyEq :: (Component target) => Proxy target -> WrappedComponent -> Bool +wrappedComponentPxyEq targetPxy (WrappedComponent(pxy,_)) = isJust $ eqProxy targetPxy pxy +{-# INLINE wrappedComponentPxyEq #-} + +-- | A definition of an empty view, which has no impact on how the screen is rendered. +emptyView :: View anything +emptyView = Html.text "" +{-# INLINE emptyView #-} diff --git a/src/Miso/Classy/App.hs b/src/Miso/Classy/App.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Classy/App.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UnicodeSyntax #-} + +module Miso.Classy.App + ( MisoApp(..) + , appToRecord + , startClientApp + , startIsoClientApp + , ViewSpec(..) + , vsRoutePath + , specToView + , defaultSubscriptions + , module Miso.Classy + ) where + +import Control.Lens hiding ( view ) +import Miso hiding ( App (..) ) +import qualified Miso +import Miso.Classy +import Network.URI ( URI (..), parseURI ) +import RFC.Prelude + +class (Component model) => MisoApp model where + createApp :: InitArgs model -> IO model + initialAction :: model -> Action model + notFoundView :: model -> WrappedComponent + viewSpec :: ALens' model ViewSpec + + subscriptions :: model -> [Sub WrappedAction] + subscriptions = const defaultSubscriptions + {-# INLINE subscriptions #-} + +instance (MisoApp model) => HasURI model where + lensURI :: Lens' model URI + lensURI = lens + (\model -> model^.(cloneLens viewSpec) & vsUri) + (\model newUri -> model & (cloneLens viewSpec) .~ + (let theRoutePath = toRoutePath newUri in + fromMaybe + (ViewSpec (notFoundView model, theRoutePath)) + (applyRoute model theRoutePath) + ) + ) + {-# INLINE lensURI #-} + +-- | These are the default subscriptions that we automatically connect to. +defaultSubscriptions :: [Sub WrappedAction] +defaultSubscriptions = [] +{-# INLINE defaultSubscriptions #-} + +applyRoute :: (MisoApp model) => model -> RoutePath -> Maybe ViewSpec +applyRoute model routePath = + foldr foldImpl (parseToVs model) subs + where + parseToVs :: forall c. Component c => c -> Maybe ViewSpec + parseToVs it = (\result -> ViewSpec (result, routePath)) <$> routeParser it routePath + foldImpl wrapped rest = mapWrappedComponent parseToVs wrapped <|> rest + subs = model^.(cloneLens subcomponents) +{-# INLINE applyRoute #-} + +-- | Converts a 'MisoApp' into a 'Miso.App' record with reasonable defaults +-- for 'Miso.events' and 'Miso.mountPoint', and everything else derived +-- from the 'MisoApp' class. +appToRecord :: (MisoApp model) => model -> Miso.App model WrappedAction +appToRecord model = Miso.App + { Miso.model = model + , Miso.update = update' + , Miso.view = fmap WrappedAction . view + , Miso.subs = subscriptions model + , Miso.events = Miso.defaultEvents + , Miso.initialAction = WrappedAction $ initialAction model + , Miso.mountPoint = Nothing + } +{-# INLINE appToRecord #-} + +-- | Starts an app with the default 'appToRecord' conversion and without +-- expecting there to be a DOM in existence. +startClientApp :: (MisoApp model, MonadIO m) => InitArgs model -> m () +startClientApp args = liftIO $ do + app <- createApp args + Miso.startApp $ appToRecord app +{-# INLINE startClientApp #-} + +-- | Starts an app with the default 'appToRecord' conversion, and assuming +-- that there is an isomorphic DOM in existence already. +startIsoClientApp :: (MisoApp model, MonadIO m) => InitArgs model -> m () +startIsoClientApp args = liftIO $ do + app <- createApp args + Miso.startApp $ appToRecord app +{-# INLINE startIsoClientApp #-} + +-- | This contains the information necessary to render a view. +newtype ViewSpec = ViewSpec (WrappedComponent, RoutePath) deriving (Eq) + +-- | Get the route path which matched for the 'ViewSpec' +vsRoutePath :: ViewSpec -> RoutePath +vsRoutePath (ViewSpec (_,rp)) = rp +{-# INLINE vsRoutePath #-} + +vsUri :: ViewSpec -> URI +vsUri (ViewSpec (_,(_,_,uri))) = uri +{-# INLINE vsUri #-} + +-- | Renders a view based on the viewspec +specToView :: ViewSpec -> View WrappedAction +specToView (ViewSpec (wrapped,_)) = mapWrappedComponent (fmap WrappedAction . view) wrapped +{-# INLINE specToView #-} diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"