packages feed

serpentine (empty) → 0.2

raw patch · 9 files changed

+672/−0 lines, 9 filesdep +basedep +pringletonsdep +serpentinesetup-changed

Dependencies added: base, pringletons, serpentine, singletons, template-haskell, text, vinyl

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright  (c) 2015++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  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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/main.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE GADTs, TypeFamilies,DataKinds,PolyKinds,KindSignatures #-}+{-# LANGUAGE RankNTypes,TypeOperators,OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances, TemplateHaskell, ScopedTypeVariables #-}+{-# LANGUAGE InstanceSigs, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}++module Main where++import Prelude+import Data.Text (Text)+import Data.Typeable +import Data.Singletons.TH+import Data.Singletons.Prelude+import Serpentine+import Serpentine.Crud+import Serpentine.PathPiece+import qualified Data.Text as Text+import qualified Data.Text.IO as Text++data Foo   = Bar | Baz+data Thing = This | That Foo+data Color = Red | Green | Blue Thing++$(singletons [d|+  data MyRoute = UsersR +               | ProfileR +               | DogR CrudRoute +               | HouseR CrudRoute +               | RenameR+    deriving (Eq,Ord,Show)+  instance Enum MyRoute where+    toEnum i+      | i == 0            = UsersR+      | i == 1            = ProfileR+      | i >= 2 && i <= 5  = DogR (toEnum (i - 2))+      | i >= 6 && i <= 9  = HouseR (toEnum (i - 6))+      | i == 10           = RenameR+    fromEnum a = go a+      where+      go UsersR = 0+      go ProfileR = 1+      go RenameR = 10+      go (DogR c) = 2 + fromEnum c+      go (HouseR c) = 6 + fromEnum c+  instance Bounded MyRoute where+    minBound = UsersR+    maxBound = RenameR+  |])++-- myChar :: Char+-- myChar = 'T'+-- +-- colorToChar :: Color -> Char+-- colorToChar c = $(constConstructors 'c ''Color 'myChar)++newtype DogId = DogId { getDogId :: Int }+  deriving (Eq,Ord,Typeable,PathPiece)++type family PlanMyRoute (k :: MyRoute) :: [Piece *] where+  PlanMyRoute 'UsersR        = '[ 'Static "user", 'Static "index"]+  PlanMyRoute 'ProfileR      = '[ 'Static "user", 'Static "profile", 'Capture Int]+  PlanMyRoute 'RenameR       = '[ 'Static "user", 'Static "edit", 'Capture Int, 'Capture Text]+  PlanMyRoute ('DogR crud)   = 'Static "dog"   ': PlanCrudRoute DogId crud+  PlanMyRoute ('HouseR crud) = 'Static "house" ': PlanCrudRoute Int crud+genDefunSymbols [''PlanMyRoute]++-- sPlanMyRoute :: SMyRoute route -> SList (PlanMyRoute route)+-- sPlanMyRoute r = case r of+--   SUsersR   -> defPieces+--   SProfileR -> defPieces+--   SRenameR  -> defPieces+--   SDogR c   -> SCons (SStatic :: SPiece ('Static "dog")) (sPlanCrudRoute (Proxy :: Proxy DogId) c)+--   SHouseR c -> SCons (SStatic :: SPiece ('Static "house")) (sPlanCrudRoute (Proxy :: Proxy Int) c)++sPlanMyRoute :: SMyRoute route -> SList (PlanMyRoute route)+sPlanMyRoute r = $(constConstructors 'r ''MyRoute 'defPieces)++parseMyRoute :: [Text] -> Maybe (SomeRoutePieces PlanMyRouteSym0)+parseMyRoute = parseAllRoutes (Proxy :: Proxy PlanMyRouteSym0) sPlanMyRoute++renderMyRoute :: Sing route +              -> IRec (PiecesNestedTuple (PlanMyRoute route))+              -> [Text] +renderMyRoute = render (Proxy :: Proxy PlanMyRouteSym0) sPlanMyRoute++main :: IO ()+main = do+  r SProfileR     (44 :& IRNil)+  r SRenameR      (33 :& "Bob" :& IRNil)+  r (SDogR SAddR) (IRNil)+  print (p "/bad/path")+  print (p "/user/edit/12/Jonathon")+  print (p "/house/edit/66")+  print (p "/dog/add")+  where +  r a = Text.putStrLn +      . Text.cons '/'+      . Text.intercalate "/"+      . renderMyRoute a+  p   = parseMyRoute+      . filter (not . Text.null) +      . Text.splitOn "/"+
+ serpentine.cabal view
@@ -0,0 +1,41 @@+name:                serpentine+version:             0.2+synopsis:            Simple project template from stack+description:         Please see README.md+homepage:            http://github.com/githubuser/serpentine#readme+license:             BSD3+license-file:        LICENSE+author:              Author name here+maintainer:          example@example.com+copyright:           2010 Author Here+category:            Web+build-type:          Simple+cabal-version:       >=1.10++library +  hs-source-dirs:      src+  exposed-modules:     +    Serpentine+    Serpentine.Crud+    Serpentine.PathPiece+    Serpentine.Playground+    Serpentine.Try+  default-language:    Haskell2010+  build-depends:       +      base >= 4.7 && < 5+    , text+    , singletons+    , template-haskell+    , vinyl+    , pringletons++executable example+  hs-source-dirs:      example+  main-is:             main.hs+  default-language:    Haskell2010+  build-depends:       +      base >= 4.7 && < 5+    , serpentine+    , text+    , singletons+
+ src/Serpentine.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE GADTs, TypeFamilies,DataKinds,PolyKinds,KindSignatures #-}+{-# LANGUAGE RankNTypes,TypeOperators,OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances, TemplateHaskell, ScopedTypeVariables #-}+{-# LANGUAGE InstanceSigs, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}++module Serpentine where++import Prelude+import Data.Text (Text)+import Data.Typeable +import Data.Singletons.TH+import Data.Singletons.Prelude+import GHC.TypeLits+import Serpentine.PathPiece+import qualified Data.Text as Text+import Language.Haskell.TH+import Control.Monad++iterConstructors :: Name -> Q Exp+iterConstructors name = stringE . show =<< reify name++constConstructors :: Name -> Name -> Name -> Q Exp+constConstructors vname name val = do+  TyConI (DataD _ _ _ ctors _) <- reify name+  matches <- forM ctors $ \(NormalC cname args) -> case args of+    [] -> return $ Match (ConP (sketchyNameSingletonize cname) []) (NormalB $ VarE val) []+    [(_,ConT tname)] -> do+      let vnameNext = mkName "j"+      r <- constConstructors vnameNext tname val+      return $ Match (ConP (sketchyNameSingletonize cname) [VarP vnameNext]) (NormalB r) []+  return $ CaseE (VarE vname) matches++sketchyNameSingletonize :: Name -> Name+sketchyNameSingletonize = id+  . mkName . ('S':) . reverse +  . takeWhile (/= '.') . reverse . show++-- constConstructors :: Name -> Name -> Name -> Q Exp+-- constConstructors vname name val = do+--   TyConI (DataD _ _ _ ctors _) <- reify name+--   matches <- forM ctors $ \(NormalC cname args) -> case args of+--     [] -> return $ Match (ConP cname []) (NormalB $ VarE val) []+--     [(_,ConT tname)] -> do+--       let vnameNext = mkName "j"+--       r <- constConstructors vnameNext tname val+--       return $ Match (ConP cname [VarP vnameNext]) (NormalB r) []+--   return $ CaseE (VarE vname) matches+++data IRec :: [*] -> * where+  IRNil :: IRec '[]+  (:&)  :: !r -> !(IRec rs) -> IRec (r ': rs)+infixr :&++data Piece x = Static Symbol | Capture x+type StaticStarH (a :: Piece *) = a+type StaticStar (s :: Symbol) = StaticStarH ('Static s)++type family PiecesNestedTuple (ks :: [Piece *]) :: [*] where+  PiecesNestedTuple '[] = '[]+  PiecesNestedTuple ('Static s ': ks) = PiecesNestedTuple ks+  PiecesNestedTuple ('Capture x ': ks) = x ': PiecesNestedTuple ks+genDefunSymbols [''PiecesNestedTuple]++data instance Sing (k :: Piece *) where+  SStatic  :: KnownSymbol s => Sing (StaticStar s)+  SCapture :: forall (x :: *). (Typeable x, PathPiece x) => Sing ('Capture x)+type SPiece (k :: Piece *) = Sing k++class DefPieces (t :: [Piece *]) where+  defPieces :: SList t++instance DefPieces '[] where+  defPieces = SNil++instance (DefPieces ps, KnownSymbol s) => DefPieces ('Static s ': ps) where+  defPieces = SCons SStatic defPieces++instance (DefPieces ps, PathPiece t, Typeable t) => DefPieces ('Capture t ': ps) where+  defPieces = SCons SCapture defPieces++sEnumAll :: forall (a :: [k]) (b :: KProxy k). +  ( a ~ EnumFromTo MinBound MaxBound+  , SBounded b, SEnum b+  )+  => SList a +sEnumAll = sEnumFromTo sMinBound sMaxBound++mapValue :: forall (rs :: [k]) b. +  (forall (r :: k). Sing r -> b) -> SList rs -> [b] +mapValue f s = case s of+  SNil -> []+  SCons sr snext -> (f sr) : mapValue f snext++data SomeRoutePieces (f :: TyFun k [Piece *] -> *) where+  SomeRoutePieces :: Sing (a :: k) -> Sing (Apply g a) +                  -> IRec (PiecesNestedTuple (Apply g a))+                  -> SomeRoutePieces g++instance ( Show (DemoteRep ('KProxy :: KProxy k)) +         , SingKind ('KProxy :: KProxy k)+         )+  => Show (SomeRoutePieces (f :: TyFun k [Piece *] -> *)) where+    show (SomeRoutePieces sroute spieces pnt) = ""+      ++ show (fromSing sroute) +      ++ " " +      ++ Text.unpack (renderCaptures spieces pnt)++renderCaptures :: forall (a :: [Piece *]). SList a +  -> IRec (PiecesNestedTuple a) -> Text+renderCaptures s pnt = case s of+  SNil -> ""+  SCons spiece snext -> case spiece of+    SStatic -> renderCaptures snext pnt+    SCapture -> case pnt of+      a :& anext -> Text.concat +        [ "("+        , toPathPiece a+        , " :: "+        , Text.pack (show (typeOf a))+        , ")"+        , " "+        , renderCaptures snext anext+        ]++parseAllRoutes :: forall (kp :: KProxy k) (f :: TyFun k [Piece *] -> *). +  (SEnum kp, SBounded kp)+  => Proxy f +  -> (forall (rt :: k). Sing rt -> Sing (Apply f rt)) +  -> [Text] +  -> Maybe (SomeRoutePieces f)+parseAllRoutes p f pieces = parseManyRoutes p f sEnumAll pieces++parseManyRoutes :: forall (routes :: [k]) (f :: TyFun k [Piece *] -> *). +     Proxy f +  -> (forall (rt :: k). Sing rt -> Sing (Apply f rt)) +  -> SList routes +  -> [Text] +  -> Maybe (SomeRoutePieces f)+parseManyRoutes p f routes pieces = case routes of+  SNil -> Nothing+  SCons sroute snext -> case parseOneRoute p f sroute pieces of+    Nothing -> parseManyRoutes p f snext pieces+    Just pnt -> Just (SomeRoutePieces sroute (f sroute) pnt)++parseOneRoute :: forall (r :: k) (f :: TyFun k [Piece *] -> *). +     Proxy f+  -> (forall (rt :: k). Sing rt -> Sing (Apply f rt)) +  -> Sing r -> [Text] -> Maybe (IRec (PiecesNestedTuple (Apply f r)))+parseOneRoute _ f r pieces = parseOne (f r) pieces++parseOne :: forall (pieces :: [Piece *]).+  SList pieces -> [Text] -> Maybe (IRec (PiecesNestedTuple pieces))+parseOne s pieces = case s of+  SNil -> if null pieces then Just IRNil else Nothing+  SCons spiece snext -> case pieces of+    [] -> Nothing+    (piece:piecesNext) -> case spiece of+      SStatic -> if renderStaticPiece spiece == piece+        then parseOne snext piecesNext+        else Nothing+      SCapture -> (:&)+        <$> parseCapturePiece spiece piece +        <*> parseOne snext piecesNext++render :: forall (f :: TyFun rk [Piece *] -> *) (route :: rk).+     Proxy f +  -> (forall r. Sing r -> Sing (Apply f r)) +  -> Sing route +  -> IRec (PiecesNestedTuple (Apply f route))+  -> [Text] -- Sing (Apply f route)+render _ f r pdata = renderPieces (f r) pdata++renderExample :: forall (f :: TyFun rk [Piece *] -> *) (route :: rk).+     Proxy f +  -> (forall r. Sing r -> Sing (Apply f r)) +  -> Sing route +  -> [Text] +renderExample _ f r = renderExamplePieces (f r)++renderExamplePieces :: forall (pieces :: [Piece *]).+     SList pieces+  -> [Text]+renderExamplePieces spieces = case spieces of+  SNil -> []+  SCons spiece spiecesNext -> case spiece of+    SStatic  -> renderStaticPiece spiece : renderExamplePieces spiecesNext+    SCapture -> Text.cons '#' (renderCapturePieceType spiece) : renderExamplePieces spiecesNext++renderPieces :: forall (pieces :: [Piece *]).+     SList pieces+  -> IRec (PiecesNestedTuple pieces)+  -> [Text]+renderPieces spieces pdata = case spieces of+  SNil  -> []+  SCons spiece spiecesNext -> case spiece of+    SStatic -> renderStaticPiece spiece : renderPieces spiecesNext pdata+    SCapture -> case pdata of+      x :& xs -> renderCapturePieceValue spiece x : renderPieces spiecesNext xs++parseCapturePiece :: (PathPiece a, piece ~ 'Capture a)+  => SPiece piece -> Text -> Maybe a+parseCapturePiece SCapture t = fromPathPiece t+parseCapturePiece _ _        = error "impossible"++renderStaticPiece :: forall static s. (static ~ 'Static s)+  => SPiece static -> Text+renderStaticPiece SStatic = Text.pack (symbolVal (Proxy :: Proxy s))+renderStaticPiece _       = error "renderStaticPiece: impossible"++renderCapturePieceValue :: (piece ~ 'Capture a)+  => SPiece piece -> a -> Text+renderCapturePieceValue SCapture t = toPathPiece t+renderCapturePieceValue _ _        = error "impossible"++renderCapturePieceType :: forall a piece. +  (piece ~ 'Capture a) => SPiece piece -> Text+renderCapturePieceType SCapture = +  Text.pack (show (typeRep (Proxy :: Proxy a)))+renderCapturePieceType _        = error "impossible"+
+ src/Serpentine/Crud.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE GADTs, TypeFamilies,DataKinds,PolyKinds,KindSignatures #-}+{-# LANGUAGE UndecidableInstances, TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE InstanceSigs, FlexibleContexts #-}++module Serpentine.Crud where++import Prelude+import Serpentine+import Serpentine.PathPiece+import Data.Singletons.TH+import Data.Singletons.Prelude+import Data.Typeable (Typeable)++$(singletons [d|+  data CrudRoute = AddR | EditR | DeleteR | ViewR+    deriving (Eq,Ord,Enum,Bounded,Show)+  |])++type family PlanCrudRoute (key :: *) (r :: CrudRoute) :: [Piece *] where+  PlanCrudRoute key 'AddR    = '[ 'Static "add"]+  PlanCrudRoute key 'EditR   = '[ 'Static "edit", 'Capture key]+  PlanCrudRoute key 'DeleteR = '[ 'Static "delete", 'Capture key]+  PlanCrudRoute key 'ViewR   = '[ 'Static "view", 'Capture key]+genDefunSymbols [''PlanCrudRoute]++sPlanCrudRoute :: (Typeable i, PathPiece i)+  => Proxy i -> SCrudRoute route -> SList (PlanCrudRoute i route)+sPlanCrudRoute _ r = case r of+  SAddR -> defPieces+  SEditR -> defPieces+  SDeleteR -> defPieces+  SViewR -> defPieces+
+ src/Serpentine/PathPiece.hs view
@@ -0,0 +1,26 @@+module Serpentine.PathPiece +  ( PathPiece(..)+  ) where++import Data.Text (Text)+import Text.Read (readMaybe)+import qualified Data.Text as Text++class PathPiece a where+  toPathPiece :: a -> Text+  fromPathPiece :: Text -> Maybe a++instance PathPiece Int where+  toPathPiece = Text.pack . show+  fromPathPiece = readMaybe . Text.unpack++instance PathPiece Char where+  toPathPiece = Text.singleton+  fromPathPiece t = if Text.length t == 1+    then Just (Text.head t)+    else Nothing++instance PathPiece Text where+  toPathPiece = id+  fromPathPiece = Just+
+ src/Serpentine/Playground.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE GADTs, TypeFamilies,DataKinds,PolyKinds,KindSignatures #-}+{-# LANGUAGE RankNTypes,TypeOperators,OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances, TemplateHaskell, ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Serpentine.Playground where++import Data.Singletons+import Data.Singletons.TH+import Data.Singletons.Prelude+import Data.Singletons.TypeLits+import Data.Vinyl.Core+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.TypeLits+import Data.Singletons.Class (Applied1(..),SomeSingWith1(..))+import Data.Maybe++data Piece x = Static Symbol | Capture x++data instance Sing (k :: Piece a) where+  SStatic :: (x ~ 'Static s) => SSymbol s -> Sing x+  SCapture :: (x ~ 'Capture b) => Sing b -> Sing x++type StaticSym1 s = 'Static s+type CaptureSym1 x = 'Capture x++data StaticSym0 :: (TyFun Symbol (Piece k) -> *)+type instance Apply StaticSym0 s = StaticSym1 s++data CaptureSym0 :: (TyFun k (Piece k) -> *)+type instance Apply CaptureSym0 s = CaptureSym1 s++$(singletons [d|+  captures :: [Piece x] -> [x]+  captures [] = []+  captures (Static _ : xs) = captures xs+  captures (Capture c : xs) = c : captures xs+  |])+++------------------------+-- Route rendering+------------------------+render :: +     Proxy f+  -> (forall route1. Sing route1 -> Sing (Apply f route1))+  -> (forall x. Sing x -> Applied1 e x -> Text)+  -> Sing route+  -> Rec (Applied1 e) (Captures (Apply f route))+  -> [Text]+render _ routeToPieces renderFunc r pdata = +  renderPieces renderFunc (routeToPieces r) pdata++renderPieces :: forall (e :: TyFun item * -> *) (pieces :: [Piece item]).+  (forall x. Sing x -> Applied1 e x -> Text)+  -> SList pieces+  -> Rec (Applied1 e) (Captures pieces)+  -> [Text]+renderPieces renderFunc spieces attrs = +  case spieces of+    SNil -> []+    SCons spiece spiecesNext -> +      case spiece of+        SStatic sym -> renderSymbol sym : renderPieces renderFunc spiecesNext attrs+        SCapture item -> +          case attrs of+            x :& xs -> renderFunc item x : renderPieces renderFunc spiecesNext xs++renderSymbol :: forall s. SSymbol s -> Text+renderSymbol SSym = Text.pack (symbolVal (Proxy :: Proxy s))++------------------------+-- Route parsing+------------------------+-- data SomeRoutePieces (f :: TyFun k [Piece *] -> *) where+--   SomeRoutePieces :: Sing (a :: k) -> Sing (Apply g a) +--                   -> Rec (Attre (PiecesNestedTuple (Apply g a))+--                   -> SomeRoutePieces g+-- ++newtype Results (e :: TyFun item * -> *) (f :: TyFun r [Piece item] -> *) (route :: r) = Results +  { getResults :: Rec (Applied1 e) (Captures (Apply f route)) }++downgradeSList :: forall (kproxy :: KProxy k) (ks :: [k]). (kproxy ~ 'KProxy) => SList ks -> [SomeSing kproxy]+downgradeSList SNil = []+downgradeSList (SCons a as) = SomeSing a : downgradeSList as++parse :: forall+     (kproxy :: KProxy route) (e :: TyFun item * -> *) +     (r :: TyFun route [Piece item] -> *).+       (kproxy ~ 'KProxy, SEnum kproxy, SBounded kproxy)+  => (forall (x :: item). Sing x -> Text -> Maybe (Applied1 e x))+  -> (forall (j :: route). Sing j -> Sing (Apply r j))+  -> [Text] +  -> Maybe (SomeSingWith1 kproxy (Results e r))+parse = parsePiecesMulti (downgradeSList (sEnumFromTo sMinBound sMaxBound))++parsePiecesMulti :: forall +     (kproxy :: KProxy route) (e :: TyFun item * -> *) +     (r :: TyFun route [Piece item] -> *).+       (kproxy ~ 'KProxy)+  => [SomeSing kproxy]+  -> (forall (x :: item). Sing x -> Text -> Maybe (Applied1 e x))+  -> (forall (j :: route). Sing j -> Sing (Apply r j))+  -> [Text] +  -> Maybe (SomeSingWith1 kproxy (Results e r))+parsePiecesMulti routes parsePiece sRouteToPieces pieces = +  listToMaybe $ mapMaybe +    (\(SomeSing route) -> +      case parsePieces parsePiece (sRouteToPieces route) pieces of+        Nothing -> Nothing+        Just a -> Just (SomeSingWith1 route (Results a))+    )+    routes++parsePieces :: forall e (pieces :: [Piece item]).+  (forall x. Sing x -> Text -> Maybe (Applied1 e x))+  -> SList pieces -> [Text] +  -> Maybe (Rec (Applied1 e) (Captures pieces))+  -- -> Maybe (Results e pieces)+parsePieces parsePiece s pieces = +  case s of+    SNil -> if null pieces then Just RNil else Nothing+    SCons spiece snext -> +      case pieces of+        [] -> Nothing+        (piece:piecesNext) -> +          case spiece of+            SStatic sym -> +              if renderSymbol sym == piece+                then parsePieces parsePiece snext piecesNext+                else Nothing+            SCapture sitem -> (:&)+              <$> parsePiece sitem piece +              <*> parsePieces parsePiece snext piecesNext++-- parseSingle :: +--   (forall x. Sing x -> Text -> Maybe (Attr e x))+--   -> SPiece item -> Text -> Maybe (Attr e item)+-- parseSingle ++
+ src/Serpentine/Try.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE GADTs, TypeFamilies,DataKinds,PolyKinds,KindSignatures #-}+{-# LANGUAGE RankNTypes,TypeOperators,OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances, TemplateHaskell, ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Serpentine.Try where++import Data.Singletons+import Data.Singletons.TH+import Data.Singletons.Prelude+import Serpentine.Playground+import Data.Text (Text)+import Data.Vinyl.Core+import qualified Data.Text as Text+import Data.Singletons.Class (Applied1(..))++$(singletons [d|+  data Item = ItemInt | ItemText | ItemBool+  data Crud = AddR | EditR | DeleteR | ViewR+  data MyRoute = UsersR +               | ProfileR +               | HomeR+               | DogR Crud+  |])+++$(singletonsOnly [d|+  planCrud :: n -> Crud -> [Piece n]+  planCrud n x = +    case x of+      AddR    -> [Static "add"]+      EditR   -> [Static "edit", Capture n]+      DeleteR -> [Static "delete", Capture n]+      ViewR   -> [Static "view", Capture n]++  plan :: MyRoute -> [Piece Item]+  plan x = +    case x of+      UsersR    -> [Static "user", Static "index"]+      ProfileR  -> [Static "profile", Capture ItemInt]+      HomeR     -> []+      DogR crud -> Static "dog" : planCrud ItemInt crud+  |])++type family ItemType (x :: Item) where+  ItemType ItemInt  = Int+  ItemType ItemText = Text+  ItemType ItemBool = Bool++genDefunSymbols [''ItemType]++renderAnyItem :: SItem x -> Applied1 ItemTypeSym0 x -> Text+renderAnyItem x attr = case x of+  SItemInt -> Text.pack $ show $ getApplied1 attr+  SItemText -> getApplied1 attr+  SItemBool -> if getApplied1 attr then "yes" else "no"++renderMyRoute :: SMyRoute x +              -> Rec (Applied1 ItemTypeSym0) (Captures (Plan x)) +              -> [Text]+renderMyRoute = render (Proxy :: Proxy PlanSym0) sPlan renderAnyItem ++test1, test2, test3 :: [Text]+test1 = renderMyRoute SProfileR (Applied1 33 :& RNil)+test2 = renderMyRoute SUsersR RNil+test3 = renderMyRoute (SDogR SViewR) (Applied1 12 :& RNil)+