Skip to content

Instantly share code, notes, and snippets.

@jacobstanley

jacobstanley/simplify-type.hs

Last active August 11, 2016 07:50
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save jacobstanley/aad625ef9ce9156c8fc4bfd6fed88116 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save jacobstanley/aad625ef9ce9156c8fc4bfd6fed88116 to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. jacobstanley revised this gist Aug 11, 2016. 1 changed file with 0 additions and 4 deletions.
    4 changes: 0 additions & 4 deletions simplify-type.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -40,10 +40,6 @@ pExactly :: Text -> Parser ()
    pExactly txt =
    fmap (const ()) . string $ T.unpack txt

    pFoos :: Parser [()]
    pFoos =
    undefined

    pMany :: Parser a -> Parser [a]
    pMany =
    many
  2. jacobstanley created this gist Aug 11, 2016.
    138 changes: 138 additions & 0 deletions simplify-type.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,138 @@
    {-# LANGUAGE DataKinds #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TypeApplications #-}
    {-# LANGUAGE TypeFamilies #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE FunctionalDependencies #-}
    {-# LANGUAGE PartialTypeSignatures #-}
    {-# LANGUAGE UndecidableInstances #-}
    module Parse where

    import Data.Proxy
    import Data.Text (Text)
    import qualified Data.Text as T
    import Text.Megaparsec
    import qualified Text.Megaparsec.Lexer as Lexer
    import Text.Megaparsec.Text

    ------------------------------------------------------------------------

    example :: Parser ([Double], Int)
    example =
    pMany pDouble |+| pExactly "foo" |+| pInt |+| pMany (pExactly "bar")

    (|+|) :: Simplify (a, b) => Parser a -> Parser b -> Parser (Simplified (a, b))
    (|+|) pa pb =
    fmap simplify ((,) <$> pa <*> pb)

    pInt :: Parser Int
    pInt =
    fromIntegral <$> Lexer.decimal

    pDouble :: Parser Double
    pDouble =
    Lexer.float

    pExactly :: Text -> Parser ()
    pExactly txt =
    fmap (const ()) . string $ T.unpack txt

    pFoos :: Parser [()]
    pFoos =
    undefined

    pMany :: Parser a -> Parser [a]
    pMany =
    many

    ------------------------------------------------------------------------

    type family Simplified a where
    Simplified (a, b) = DropUnit (Simplified a, Simplified b)
    Simplified a = DropUnit a

    type family DropUnit a where
    DropUnit ((), a) = a
    DropUnit (a, ()) = a
    DropUnit [()] = ()
    DropUnit a = a

    class Simplify a where
    simplify :: a -> Simplified a

    instance (SimplifyCase scase a, SCase a ~ scase) => Simplify a where
    simplify =
    simplifyCase (Proxy :: Proxy scase)

    ------------------------------------------------------------------------
    -- Simplify

    data SC = SC_1 | SC_Otherwise

    type family SCase a where
    SCase (a, b) =
    SC_1
    SCase a =
    SC_Otherwise

    class SimplifyCase (scase :: SC) a where
    simplifyCase :: Proxy scase -> a -> Simplified a

    instance
    ( DropCase (DCase (Simplified a, Simplified b)) (Simplified a, Simplified b)
    , SimplifyCase (SCase a) a
    , SimplifyCase (SCase b) b
    ) => SimplifyCase SC_1 (a, b) where
    simplifyCase _ (a0, b0) =
    let
    a =
    simplifyCase (Proxy :: Proxy (SCase a)) a0

    b =
    simplifyCase (Proxy :: Proxy (SCase b)) b0
    in
    dropCase (Proxy :: Proxy (DCase (Simplified a, Simplified b))) (a, b)

    instance
    ( DropCase (DCase a) a
    , Simplified a ~ DropUnit a
    ) => SimplifyCase SC_Otherwise a where
    simplifyCase _ a =
    dropCase (Proxy :: Proxy (DCase a)) a

    ------------------------------------------------------------------------
    -- Drop Unit

    data DC = DC_1 | DC_2 | DC_3 | DC_Otherwise

    type family DCase a where
    DCase ((), a) =
    DC_1
    DCase (a, ()) =
    DC_2
    DCase [()] =
    DC_3
    DCase a =
    DC_Otherwise

    class DropCase (dcase :: DC) a where
    dropCase :: Proxy dcase -> a -> DropUnit a

    instance DropCase DC_1 ((), a) where
    dropCase _ ((), a) =
    a

    instance DropCase DC_2 (a, ()) where
    dropCase _ (a, ()) =
    a

    instance DropCase DC_3 [()] where
    dropCase _ _ =
    ()

    instance (DropUnit a ~ a) => DropCase DC_Otherwise a where
    dropCase _ a =
    a