serpentine-0.2: example/main.hs

{-# 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 "/"