overloaded (empty) → 0.1
raw patch · 21 files changed
+1527/−0 lines, 21 filesdep +HUnitdep +basedep +bytestring
Dependencies added: HUnit, base, bytestring, containers, fin, generic-lens, ghc, lens, overloaded, sop-core, split, syb, symbols, tasty, tasty-hunit, text, vec
Files
- LICENSE +31/−0
- example/Example.hs +111/−0
- overloaded.cabal +117/−0
- src/Overloaded.hs +41/−0
- src/Overloaded/Chars.hs +24/−0
- src/Overloaded/If.hs +40/−0
- src/Overloaded/Lists.hs +91/−0
- src/Overloaded/Naturals.hs +29/−0
- src/Overloaded/Numerals.hs +117/−0
- src/Overloaded/Plugin.hs +531/−0
- src/Overloaded/Symbols.hs +76/−0
- test/Overloaded/Test/Chars.hs +11/−0
- test/Overloaded/Test/If.hs +13/−0
- test/Overloaded/Test/Labels.hs +35/−0
- test/Overloaded/Test/Labels/GenericLens.hs +51/−0
- test/Overloaded/Test/Lists.hs +94/−0
- test/Overloaded/Test/Naturals.hs +14/−0
- test/Overloaded/Test/Numerals.hs +24/−0
- test/Overloaded/Test/Strings.hs +15/−0
- test/Overloaded/Test/Symbols.hs +35/−0
- test/Tests.hs +27/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2019 Oleg Grenrus++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 Don Stewart 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.
+ example/Example.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedLabels #-}+-- {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Symbols:Numerals:Lists:If:Labels=Overloaded.Symbols.fromSymbol #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+module Main (main) where++import qualified Data.ByteString as BS+import Data.Fin (Fin (..))+import Data.Proxy (Proxy (..))+import Data.SOP.BasicFunctors (I (..))+import Data.SOP.NP (NP (..), POP (..))+import Data.String (IsString (..))+import Data.Symbol.Ascii (ReadNat)+import Data.Type.Equality+import qualified Data.Type.Nat as N+import Data.Vec.Lazy (Vec (..))+import GHC.Exts (Constraint)+import GHC.OverloadedLabels (IsLabel (..))+import GHC.TypeLits (ErrorMessage (..), TypeError, KnownSymbol, KnownNat, symbolVal, Symbol)+import qualified GHC.TypeNats as Nat+import Numeric.Natural+import Test.HUnit ((@?=))++import Overloaded++-- non-empty string+newtype NES = NES String deriving (Eq, Show)++instance IsString NES where+ fromString = NES++type family NotEmptySymbol (s :: Symbol) :: Constraint where+ NotEmptySymbol "" = TypeError ('ShowType NES ':<>: 'Text " should not be empty")+ NotEmptySymbol s = ()++instance (KnownSymbol s, NotEmptySymbol s) => FromSymbol s NES where+ fromSymbol = NES $ symbolVal (Proxy :: Proxy s)++-- We don't need this instance, as we have configured the plugin+-- instance (KnownSymbol s, NotEmptySymbol s) => IsLabel s NES where+-- fromLabel = fromSymbol @s++-- | Orphan instance for natural+instance (KnownNat (ReadNat s)) => FromSymbol s Natural where+ fromSymbol = Nat.natVal (Proxy :: Proxy (ReadNat s))++++main :: IO ()+main = do+ --Non-Empty String+ let lhs = "foo"+ print lhs+ lhs @?= NES "foo"++ let lhs' = #foo+ print lhs+ lhs' @?= NES "foo"++ -- ByteString+ let bs = "foo" -- try non-ASCII+ bs @?= BS.pack [102, 111, 111]++ -- Numbers+ let n = "2" -- try non digit+ print n+ 1 + n @?= (3 :: Natural)++ -- fin: Fin+ let f :: Fin (N.FromGHC 5)+ f = 2++ print f+ f @?= FS (FS FZ)++ -- vec: Vec+ let v :: Vec N.Nat3 Int+ v = [1, 2, 3]++ print v+ v @?= 1 ::: 2 ::: 3 ::: VNil++ -- sop-core: NP and POP+ let np :: NP I '[Int, Bool, String]+ np = [I 1, I True, I "YES"]++ print np+ np @?= I 1 :* I True :* I "YES" :* Nil++ let pop :: POP I '[ '[Int, Bool], '[String] ]+ pop = [[I 0, I False], [I "NO"]]++ print pop+ pop @?= POP ((I 0 :* I False :* Nil) :* (I "NO" :* Nil) :* Nil)++ -- Overloaded:If+ (if True then 'x' else 'y') @?= ('x' :: Char)+ (if Just 'b' then 'x' else 'y') @?= ('x' :: Char)++
+ overloaded.cabal view
@@ -0,0 +1,117 @@+cabal-version: 2.2+name: overloaded+version: 0.1+synopsis: Overloaded pragmas as a plugin+description:+ Implement @Overloaded@ pragmas as a source plugin+ .+ For example we can replace+ .+ @+ {-\# LANGUAGE OverloadedStrings #-}+ @+ .+ with+ .+ @+ {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Strings #-}+ @++license: BSD-3-Clause+license-file: LICENSE+author: Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+category: Plugin+tested-with: GHC ==8.6.5 || ==8.8.1++source-repository head+ type: git+ location: https://github.com/phadej/overloaded.git++library+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -Wall+ exposed-modules:+ Overloaded+ Overloaded.Chars+ Overloaded.If+ Overloaded.Lists+ Overloaded.Naturals+ Overloaded.Numerals+ Overloaded.Plugin+ Overloaded.Symbols++ -- GHC boot dependencies+ build-depends:+ , base ^>=4.12.0.0 || ^>=4.13.0.0+ , bytestring ^>=0.10.8.2+ , containers ^>=0.6.0.1+ , ghc ^>=8.6 || ^>=8.8+ , text ^>=1.2.3.0++ -- other dependencies+ build-depends:+ , fin ^>=0.1+ , sop-core ^>=0.5.0.0+ , split ^>=0.2.3.3+ , syb ^>=0.7.1+ , symbols ^>=0.3.0.0+ , vec ^>=0.1.1.1++test-suite example+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: example+ main-is: Example.hs++ -- inherited dependencies+ build-depends:+ , base+ , bytestring+ , fin+ , overloaded+ , sop-core+ , symbols+ , vec++ -- test dependencies+ build-depends:+ , HUnit ^>=1.6.0.0+ , tasty+ , tasty-hunit++test-suite test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Tests.hs+ other-modules:+ Overloaded.Test.Chars+ Overloaded.Test.If+ Overloaded.Test.Labels+ Overloaded.Test.Labels.GenericLens+ Overloaded.Test.Lists+ Overloaded.Test.Naturals+ Overloaded.Test.Numerals+ Overloaded.Test.Strings+ Overloaded.Test.Symbols++ -- inherited dependencies+ build-depends:+ , base+ , bytestring+ , containers+ , fin+ , overloaded+ , sop-core+ , symbols+ , text+ , vec++ -- test dependencies+ build-depends:+ , generic-lens ^>=1.2.0.0+ , lens ^>=4.18+ , tasty ^>=1.2.3+ , tasty-hunit ^>=0.10.0.2
+ src/Overloaded.hs view
@@ -0,0 +1,41 @@+-- | @Overloaded*@ language extensions as a source plugin.+module Overloaded (+ -- * Plugin+ plugin,++ -- * Overloaded:Symbols+ FromSymbol (..),++ -- * Overloaded:Strings+ -- | See "Data.String" for 'Data.String.fromString'.++ -- * Overloaded:Numerals+ FromNumeral (..),+ defaultFromNumeral,++ -- * Overloaded:Naturals+ FromNatural (..),++ -- * Overloaded:Chars+ FromChar (..),++ -- * Overloaded:Lists+ Nil (..), Cons (..),++ -- * Overloaded:If+ ToBool (..),+ ifte,++ -- * Overloaded:Labels+ -- | See "GHC.OverloadedLabels" for 'GHC.OverloadedLabels.fromLabel'.+ --+ -- generic-lens example!+ ) where++import Overloaded.Chars+import Overloaded.If+import Overloaded.Lists+import Overloaded.Naturals+import Overloaded.Numerals+import Overloaded.Plugin+import Overloaded.Symbols
+ src/Overloaded/Chars.hs view
@@ -0,0 +1,24 @@+-- | Overloaded characters.+module Overloaded.Chars (+ FromChar (..),+ ) where++-- | Class for 'Char'-like datastructures+--+-- A character literal @'x'@ is desugared to+--+-- @+-- 'fromChar' \'x\'+-- @+--+---- Enabled with:+--+-- @+-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Chars #-}+-- @+--+class FromChar a where+ fromChar :: Char -> a++instance FromChar Char where+ fromChar = id
+ src/Overloaded/If.hs view
@@ -0,0 +1,40 @@+-- | Overloaded @if@-expression.+module Overloaded.If (+ ToBool (..),+ ifte,+ ) where++import Data.Maybe (isJust)+import Data.Either (isRight)++-- | Class for 'Bool'-like datastrucutres+--+-- An @if-@-expression @if b then t else e@ is desugared to+--+-- @+-- ifte ('toBool' b) t e+-- @+--+-- Enabled with:+--+-- @+-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:If #-}+-- @+--+class ToBool b where+ toBool :: b -> Bool++instance ToBool Bool where+ toBool = id++-- | 'Just' is 'True'+instance ToBool (Maybe a) where+ toBool = isJust++-- | 'Right' is 'True'+instance ToBool (Either b a) where+ toBool = isRight++-- | 'ToBool' overloaded @if@-expression.+ifte :: ToBool b => b -> a -> a -> a+ifte b t e = if toBool b then t else e
+ src/Overloaded/Lists.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Another way to desugar overloaded numeric literals. See 'FromNatural'.+--+-- An explicit list expression, e.g. @[1, True]@ is desugared to+--+-- @+-- cons 1 (cons True nil)+-- @+--+-- Enabled with:+--+-- @+-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Lists #-}+-- @+--+module Overloaded.Lists (+ Nil (..),+ Cons (..),+ ) where++import Data.SOP.NP (NP (..), POP (..))+import Data.List.NonEmpty (NonEmpty (..))+import Data.Coerce (coerce)++import qualified Data.Vec.Lazy as Vec+import qualified Data.Type.Nat as N++-------------------------------------------------------------------------------+-- Classes+-------------------------------------------------------------------------------++-- | Class for nil, @[]@+--+-- See test-suite for ways to define instances for 'Data.Map.Map'.+-- There are at-least two-ways.+-- +class Nil a where+ nil :: a++-- | Class for Cons ':'.+class Cons x ys zs | zs -> x ys where+ cons :: x -> ys -> zs++-------------------------------------------------------------------------------+-- base+-------------------------------------------------------------------------------++instance Nil [a] where+ nil = []++instance Cons a [a] [a] where+ cons = (:)++instance Cons a [a] (NonEmpty a) where+ cons = (:|)++-------------------------------------------------------------------------------+-- vec+-------------------------------------------------------------------------------++instance n ~ 'N.Z => Nil (Vec.Vec n a) where+ nil = Vec.VNil++instance Cons a (Vec.Vec n a) (Vec.Vec ('N.S n) a) where+ cons = (Vec.:::)++-------------------------------------------------------------------------------+-- sop-core+-------------------------------------------------------------------------------++instance xs ~ '[] => Nil (NP f xs) where+ nil = Nil++instance Cons (f x) (NP f xs) (NP f (x ': xs)) where+ cons = (:*)++instance xs ~ '[] => Nil (POP f xs) where+ nil = POP Nil++instance Cons (NP f xs) (POP f xss) (POP f (xs ': xss)) where+ cons = coerce ((:*) :: NP f xs -> NP (NP f) xss -> NP (NP f) (xs ': xss))
+ src/Overloaded/Naturals.hs view
@@ -0,0 +1,29 @@+-- | Overloaded natural numbers.+module Overloaded.Naturals (+ FromNatural (..),+ ) where++import Numeric.Natural (Natural)+--+-- | Class for 'Natural'-like datastructures+--+-- A numeric literal @42@ is desugared to+--+-- @+-- 'fromNatural' 42+-- @+--+---- Enabled with:+--+-- @+-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Naturals #-}+-- @+--+class FromNatural a where+ fromNatural :: Natural -> a++instance FromNatural Natural where+ fromNatural = id++instance FromNatural Integer where+ fromNatural = fromIntegral
+ src/Overloaded/Numerals.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Another way to desugar overloaded numeric literals. See 'FromNumeral'.+module Overloaded.Numerals (+ FromNumeral (..),+ defaultFromNumeral,+ ) where++import Data.Fin (Fin (..))+import Data.Proxy (Proxy (..))+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.Exts (Constraint)+import GHC.TypeLits (ErrorMessage (..), Symbol, TypeError)+import GHC.TypeNats (type (<=?), KnownNat, Nat, natVal)+import Numeric.Natural (Natural)++import qualified Data.Type.Nat as N++-- | Another way to desugar numerals.+--+-- A numeric literal @123@ is desugared to+--+-- @+-- 'fromNumeral' \@123+-- @+--+-- Enabled with:+--+-- @+-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Numerals #-}+-- @+--+-- One can do type-level computations with this.+--+class FromNumeral (n :: Nat) a where+ fromNumeral :: a++-- | Default implementation of 'fromNumeral'.+--+-- Usage example:+--+-- @+-- instance ('KnownNat' n, ...) => 'FromNumeral' n MyType where+-- 'fromNumeral' = 'defaultFromNumeral' @n+-- @+--+defaultFromNumeral :: forall n a. (KnownNat n, Integral a) => a+defaultFromNumeral = fromIntegral $ natVal (Proxy :: Proxy n)++-------------------------------------------------------------------------------+-- base+-------------------------------------------------------------------------------++instance KnownNat n => FromNumeral n Natural where+ fromNumeral = natVal (Proxy :: Proxy n)++instance KnownNat n => FromNumeral n Integer where+ fromNumeral = defaultFromNumeral @n++-- | TODO: currently there is no range check+instance KnownNat n => FromNumeral n Int where+ fromNumeral = defaultFromNumeral @n++-------------------------------------------------------------------------------+-- Word+-------------------------------------------------------------------------------++type family OverflowCheck (n :: Nat) (t :: Symbol) (b :: Bool) :: Constraint where+ OverflowCheck n t 'True = ()+ OverflowCheck n t 'False = TypeError+ ('Text "Overflowing " ':<>: 'Text t ':<>: 'Text ": " ':<>: 'ShowType n)++instance (KnownNat n, OverflowCheck n "Word8" (n <=? 0xff)) => FromNumeral n Word8 where+ fromNumeral = defaultFromNumeral @n++instance (KnownNat n, OverflowCheck n "Word8" (n <=? 0xffff)) => FromNumeral n Word16 where+ fromNumeral = defaultFromNumeral @n++instance (KnownNat n, OverflowCheck n "Word8" (n <=? 0xffffffff)) => FromNumeral n Word32 where+ fromNumeral = defaultFromNumeral @n++instance (KnownNat n, OverflowCheck n "Word8" (n <=? 0xffffffffffffffff)) => FromNumeral n Word64 where+ fromNumeral = defaultFromNumeral @n++-------------------------------------------------------------------------------+-- fin+-------------------------------------------------------------------------------++instance KnownNat n => FromNumeral n N.Nat where+ fromNumeral = defaultFromNumeral @n++type family IsLess (n :: N.Nat) (m :: N.Nat) (p :: Nat) (q :: Nat) :: Constraint where+ IsLess 'N.Z ('N.S m) p q = ()+ IsLess ('N.S n) ('N.S m) p q = IsLess n m p q+ IsLess ('N.S n) 'N.Z p q = TypeError ('ShowType p ':<>: 'Text " is not less than " ':<>: 'ShowType q)++class FinFromNumeral (n :: N.Nat) (m :: N.Nat) where+ finFromNumeral :: Proxy n -> Fin m++instance FinFromNumeral 'N.Z ('N.S m) where+ finFromNumeral _ = FZ++instance FinFromNumeral n m => FinFromNumeral ('N.S n) ('N.S m) where+ finFromNumeral _ = FS (finFromNumeral (Proxy :: Proxy n))++instance (FinFromNumeral (N.FromGHC n) m, IsLess (N.FromGHC n) m n (N.ToGHC m)) => FromNumeral n (Fin m) where+ fromNumeral = finFromNumeral (Proxy :: Proxy (N.FromGHC n))
+ src/Overloaded/Plugin.hs view
@@ -0,0 +1,531 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+-- | Overloaded plugin, which makes magic possible.+module Overloaded.Plugin (plugin) where++import Control.Applicative ((<|>))+import Control.Monad (foldM, when)+import Control.Monad.IO.Class (MonadIO (..))+import Data.List (foldl', intercalate)+import Data.List.Split (splitOn)+import Data.Maybe (catMaybes)++import qualified Data.Generics as SYB++-- GHC stuff+import qualified ErrUtils as Err+import qualified Finder+import qualified GhcPlugins as GHC+import HsSyn+import qualified IfaceEnv+import SrcLoc+import qualified TcRnMonad as TcM+import qualified TcRnTypes++-------------------------------------------------------------------------------+-- Plugin+-------------------------------------------------------------------------------++-- | @Overloaded@ plugin.+--+-- To enable plugin put the following at top of the module:+--+-- @+-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Symbols #-}+-- @+--+-- At least one option is required, multiple can given+-- either using multiple @-fplugin-opt@ options, or by separating options+-- with colon:+--+-- @+-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Symbols:Numerals #-}+-- @+--+-- Options also take optional desugaring names, for example+--+-- @+-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Labels=Data.Generics.ProductFields.field #-}+-- @+--+-- to desugar @OverloadedLabels@ directly into 'field' from @generics-lens@ (no need to import orphan instance!)+--+-- == Supported options+--+-- * @Symbols@ desugars literal strings to @'Overloaded.Symbols.fromSymbol' \@sym@+-- * @Strings@ works like built-in @OverloadedStrings@ (but you can use different method than 'Data.String.fromString')+-- * @Numerals@ desugars literal numbers to @'Overloaded.Numerals.fromNumeral' \@nat@+-- * @Naturals@ desugars literal numbers to @'Overloaded.Naturals.fromNatural' nat@ (i.e. like 'Data.String.fromString')+-- * @Chars@ desugars literal characters to @'Overloaded.Chars.fromChars' c@. /Note:/ there isn't type-level alternative: we cannot promote 'Char's.+-- * @Lists@ __is not__ like built-in @OverloadedLists@, but desugars explicit lists to 'Overloaded.Lists.cons' and 'Overloaded.Lists.nil'+-- * @If@ desugars @if@-expressions to @'Overloaded.If.ifte' b t e@+-- * @Labels@ works like built-in @OverloadedLabels@ (you should enable @OverloadedLabels@ so parser recognises the syntax)+--+-- == Known limitations+--+-- * Doesn't desugar inside patterns+--+plugin :: GHC.Plugin+plugin = GHC.defaultPlugin+ { GHC.renamedResultAction = pluginImpl+ , GHC.pluginRecompile = GHC.purePlugin+ }++pluginImpl+ :: [GHC.CommandLineOption]+ -> TcRnTypes.TcGblEnv+ -> HsGroup GhcRn+ -> TcRnTypes.TcM (TcRnTypes.TcGblEnv, HsGroup GhcRn)+pluginImpl args' env gr = do+ dflags <- GHC.getDynFlags+ topEnv <- TcM.getTopEnv++ debug $ show args+ debug $ GHC.showPpr dflags gr++ names <- getNames dflags topEnv+ opts@Options {..} <- parseArgs dflags args+ when (opts == defaultOptions) $+ warn dflags noSrcSpan $ GHC.text "No Overloaded features enabled"++ let transformNoOp :: LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)+ transformNoOp _ = Nothing++ trStr <- case optStrings of+ NoStr -> return transformNoOp+ Str Nothing -> return $ transformStrings names+ Sym Nothing -> return $ transformSymbols names+ Str (Just vn) -> do+ n <- lookupVarName dflags topEnv vn+ return $ transformStrings $ names { fromStringName = n }+ Sym (Just vn) -> do+ n <- lookupVarName dflags topEnv vn+ return $ transformSymbols $ names { fromSymbolName = n }++ trNum <- case optNumerals of+ NoNum -> return transformNoOp+ IsNum Nothing -> return $ transformNumerals names+ IsNat Nothing -> return $ transformNaturals names+ IsNum (Just vn) -> do+ n <- lookupVarName dflags topEnv vn+ return $ transformNumerals $ names { fromNumeralName = n }+ IsNat (Just vn) -> do+ n <- lookupVarName dflags topEnv vn+ return $ transformNaturals $ names { fromNaturalName = n }++ trChr <- case optChars of+ Off -> return transformNoOp+ On Nothing -> return $ transformChars names+ On (Just vn) -> do+ n <- lookupVarName dflags topEnv vn+ return $ transformChars $ names { fromCharName = n }++ trLists <- case optLists of+ Off -> return transformNoOp+ On Nothing -> return $ transformLists names+ On (Just (V2 xn yn)) -> do+ x <- lookupVarName dflags topEnv xn+ y <- lookupVarName dflags topEnv yn+ return $ transformLists $ names { nilName = x, consName = y }++ trIf <- case optIf of+ Off -> return transformNoOp+ On Nothing -> return $ transformIf names+ On (Just vn) -> do+ n <- lookupVarName dflags topEnv vn+ return $ transformIf $ names { ifteName = n }++ trLabel <- case optLabels of+ Off -> return transformNoOp+ On Nothing -> return $ transformLabels names+ On (Just vn) -> do+ n <- lookupVarName dflags topEnv vn+ return $ transformLabels $ names { fromLabelName = n }++ let tr = trStr /\ trNum /\ trChr /\ trLists /\ trIf /\ trLabel++ gr' <- transform dflags tr gr++ return (env, gr')+ where+ args = concatMap (splitOn ":") args'++ (/\) :: (a -> Maybe b) -> (a -> Maybe b) -> a -> Maybe b+ f /\ g = \x -> f x <|> g x++ infixr 9 /\ -- hello CPP++-------------------------------------------------------------------------------+-- Args parasing+-------------------------------------------------------------------------------++parseArgs :: GHC.DynFlags -> [String] -> TcRnTypes.TcM Options+parseArgs dflags = foldM go0 defaultOptions where+ go0 opts arg = do+ (arg', vns) <- elaborateArg arg+ go opts arg' vns++ go opts "Strings" vns = do+ when (isSym $ optStrings opts) $ warn dflags noSrcSpan $+ GHC.text "Overloaded:Strings and Overloaded:Symbols enabled"+ GHC.$$+ GHC.text "picking Overloaded:Strings"++ mvn <- oneName "Strings" vns+ return $ opts { optStrings = Str mvn }++ go opts "Symbols" vns = do+ when (isStr $ optStrings opts) $ warn dflags noSrcSpan $+ GHC.text "Overloaded:Strings and Overloaded:Symbols enabled"+ GHC.$$+ GHC.text "picking Overloaded:Symbols"++ mvn <- oneName "Symbols" vns+ return $ opts { optStrings = Sym mvn }++ go opts "Numerals" vns = do+ when (isNat $ optNumerals opts) $ warn dflags noSrcSpan $+ GHC.text "Overloaded:Numerals and Overloaded:Naturals enabled"+ GHC.$$+ GHC.text "picking Overloaded:Numerals"++ mvn <- oneName "Numerals" vns+ return $ opts { optNumerals = IsNum mvn }++ go opts "Naturals" vns = do+ when (isNum $ optNumerals opts) $ warn dflags noSrcSpan $+ GHC.text "Overloaded:Numerals and Overloaded:Naturals enabled"+ GHC.$$+ GHC.text "picking Overloaded:Naturals"++ mvn <- oneName "Naturals" vns+ return $ opts { optNumerals = IsNat mvn }++ go opts "Chars" vns = do+ mvn <- oneName "Chars" vns+ return $ opts { optChars = On mvn }+ go opts "Lists" vns = do+ mvn <- twoNames "Lists" vns+ return $ opts { optLists = On mvn }+ go opts "If" vns = do+ mvn <- oneName "If" vns+ return $ opts { optIf = On mvn }+ go opts "Labels" vns = do+ mvn <- oneName "Symbols" vns+ return $ opts { optLabels = On mvn }++ go opts s _ = do+ warn dflags noSrcSpan $ GHC.text $ "Unknown Overloaded option " ++ show s+ return opts++ oneName arg vns = case vns of+ [] -> return Nothing+ [vn] -> return (Just vn)+ (vn:_) -> do+ warn dflags noSrcSpan $ GHC.text $ "Multiple desugaring names specified for " ++ arg+ return (Just vn)++ twoNames arg vns = case vns of+ [] -> return Nothing+ [_] -> do+ warn dflags noSrcSpan $ GHC.text $ "Only single desugaring name specified for " ++ arg+ return Nothing+ [x,y] -> return (Just (V2 x y))+ (x:y:_) -> do+ warn dflags noSrcSpan $ GHC.text $ "Over two names specified for " ++ arg+ return (Just (V2 x y))++ elaborateArg :: String -> TcRnTypes.TcM (String, [VarName])+ elaborateArg s = case splitOn "=" s of+ [] -> return ("", [])+ (pfx:xs) -> do+ vns <- traverse parseVarName xs+ return (pfx, catMaybes vns)++ parseVarName :: String -> TcRnTypes.TcM (Maybe VarName)+ parseVarName "" = return Nothing+ parseVarName xs = do+ let ps = splitOn "." xs+ return (Just (VN (intercalate "." $ init ps) (last ps)))++data Options = Options+ { optStrings :: StrSym+ , optNumerals :: NumNat+ , optChars :: OnOff VarName+ , optLists :: OnOff (V2 VarName)+ , optIf :: OnOff VarName+ , optLabels :: OnOff VarName+ }+ deriving (Eq, Show)++defaultOptions :: Options+defaultOptions = Options+ { optStrings = NoStr+ , optNumerals = NoNum+ , optChars = Off+ , optLists = Off+ , optIf = Off+ , optLabels = Off+ }++data StrSym+ = NoStr+ | Str (Maybe VarName)+ | Sym (Maybe VarName)+ deriving (Eq, Show)++isSym :: StrSym -> Bool+isSym (Sym _) = True+isSym _ = False++isStr :: StrSym -> Bool+isStr (Str _) = True+isStr _ = False++data NumNat+ = NoNum+ | IsNum (Maybe VarName)+ | IsNat (Maybe VarName)+ deriving (Eq, Show)++isNum :: NumNat -> Bool+isNum (IsNum _) = True+isNum _ = False++isNat :: NumNat -> Bool+isNat (IsNat _) = True+isNat _ = False++data OnOff a+ = Off+ | On (Maybe a)+ deriving (Eq, Show)++-------------------------------------------------------------------------------+-- OverloadedStrings+-------------------------------------------------------------------------------++transformStrings :: Names -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)+transformStrings Names {..} e@(L l (HsLit _ (HsString _ _fs))) =+ Just $ hsApps l (hsVar l fromStringName) [e]++transformStrings _ _ = Nothing++-------------------------------------------------------------------------------+-- OverloadedSymbols+-------------------------------------------------------------------------------++transformSymbols :: Names -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)+transformSymbols Names {..} (L l (HsLit _ (HsString _ fs))) = do+ let name' = hsVar l fromSymbolName+ let inner = hsTyApp l name' (HsTyLit noExt (HsStrTy GHC.NoSourceText fs))+ Just inner++transformSymbols _ _ = Nothing++-------------------------------------------------------------------------------+-- OverloadedNumerals+-------------------------------------------------------------------------------++transformNumerals :: Names -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)+transformNumerals Names {..} (L l (HsOverLit _ (OverLit _ (HsIntegral (GHC.IL _ n i)) _)))+ | not n, i >= 0 = do+ let name' = hsVar l fromNumeralName+ let inner = hsTyApp l name' (HsTyLit noExt (HsNumTy GHC.NoSourceText i))+ Just inner++transformNumerals _ _ = Nothing++-------------------------------------------------------------------------------+-- OverloadedNaturals+-------------------------------------------------------------------------------++transformNaturals :: Names -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)+transformNaturals Names {..} e@(L l (HsOverLit _ (OverLit _ (HsIntegral (GHC.IL _ n i)) _)))+ | not n, i >= 0 = do+ Just $ hsApps l (hsVar l fromNaturalName) [e]++transformNaturals _ _ = Nothing++-------------------------------------------------------------------------------+-- OverloadedChars+-------------------------------------------------------------------------------++transformChars :: Names -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)+transformChars Names {..} e@(L l (HsLit _ (HsChar _ _))) =+ Just $ hsApps l (hsVar l fromCharName) [e]++transformChars _ _ = Nothing++-------------------------------------------------------------------------------+-- OverloadedLists+-------------------------------------------------------------------------------++transformLists :: Names -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)+transformLists Names {..} (L l (ExplicitList _ Nothing xs)) =+ Just $ foldr cons' nil' xs+ where+ cons' :: LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn+ cons' y ys = hsApps l (hsVar l consName) [y, ys]++ nil' :: LHsExpr GhcRn+ nil' = hsVar l nilName++ -- otherwise: leave intact+transformLists _ _ = Nothing++-------------------------------------------------------------------------------+-- OverloadedIf+-------------------------------------------------------------------------------++transformIf :: Names -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)+transformIf Names {..} (L l (HsIf _ _ co th el)) = Just val4 where+ val4 = L l $ HsApp noExt val3 el+ val3 = L l $ HsApp noExt val2 th+ val2 = L l $ HsApp noExt val1 co+ val1 = L l $ HsVar noExt $ L l ifteName+transformIf _ _ = Nothing++-------------------------------------------------------------------------------+-- OverloadedLabels+-------------------------------------------------------------------------------++transformLabels :: Names -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)+transformLabels Names {..} (L l (HsOverLabel _ Nothing fs)) = do+ let name' = hsVar l fromLabelName+ let inner = hsTyApp l name' (HsTyLit noExt (HsStrTy GHC.NoSourceText fs))+ Just inner++transformLabels _ _ = Nothing++-------------------------------------------------------------------------------+-- Transform+-------------------------------------------------------------------------------++transform+ :: GHC.DynFlags+ -> (LHsExpr GhcRn -> Maybe (LHsExpr GhcRn))+ -> HsGroup GhcRn+ -> TcRnTypes.TcM (HsGroup GhcRn)+transform _dflags f = SYB.everywhereM (SYB.mkM transform') where+ transform' :: LHsExpr GhcRn -> TcRnTypes.TcM (LHsExpr GhcRn)+ transform' e = do+ return $ case f e of+ Just e' -> e'+ Nothing -> e++-------------------------------------------------------------------------------+-- Constructors+-------------------------------------------------------------------------------++hsVar :: SrcSpan -> GHC.Name -> LHsExpr GhcRn+hsVar l n = L l (HsVar noExt (L l n))++hsApps :: SrcSpan -> LHsExpr GhcRn -> [LHsExpr GhcRn] -> LHsExpr GhcRn+hsApps l = foldl' app where+ app :: LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn+ app f x = L l (HsApp noExt f x)++hsTyApp :: SrcSpan -> LHsExpr GhcRn -> HsType GhcRn -> LHsExpr GhcRn+#if MIN_VERSION_ghc(8,8,0)+hsTyApp l x ty = L l $ HsAppType noExt x (HsWC [] (L l ty))+#else+hsTyApp l x ty = L l $ HsAppType (HsWC [] (L l ty)) x+#endif++-------------------------------------------------------------------------------+-- ModuleNames+-------------------------------------------------------------------------------++dataStringMN :: GHC.ModuleName+dataStringMN = GHC.mkModuleName "Data.String"++overloadedCharsMN :: GHC.ModuleName+overloadedCharsMN = GHC.mkModuleName "Overloaded.Chars"++overloadedSymbolsMN :: GHC.ModuleName+overloadedSymbolsMN = GHC.mkModuleName "Overloaded.Symbols"++overloadedNaturalsMN :: GHC.ModuleName+overloadedNaturalsMN = GHC.mkModuleName "Overloaded.Naturals"++overloadedNumeralsMN :: GHC.ModuleName+overloadedNumeralsMN = GHC.mkModuleName "Overloaded.Numerals"++overloadedListsMN :: GHC.ModuleName+overloadedListsMN = GHC.mkModuleName "Overloaded.Lists"++overloadedIfMN :: GHC.ModuleName+overloadedIfMN = GHC.mkModuleName "Overloaded.If"++ghcOverloadedLabelsMN :: GHC.ModuleName+ghcOverloadedLabelsMN = GHC.mkModuleName "GHC.OverloadedLabels"++-------------------------------------------------------------------------------+-- Names+-------------------------------------------------------------------------------++data Names = Names+ { fromStringName :: GHC.Name+ , fromSymbolName :: GHC.Name+ , fromNumeralName :: GHC.Name+ , fromNaturalName :: GHC.Name+ , fromCharName :: GHC.Name+ , nilName :: GHC.Name+ , consName :: GHC.Name+ , ifteName :: GHC.Name+ , fromLabelName :: GHC.Name+ }++getNames :: GHC.DynFlags -> GHC.HscEnv -> TcRnTypes.TcM Names+getNames dflags env = do+ fromStringName <- lookupName dflags env dataStringMN "fromString"+ fromSymbolName <- lookupName dflags env overloadedSymbolsMN "fromSymbol"+ fromNumeralName <- lookupName dflags env overloadedNumeralsMN "fromNumeral"+ fromNaturalName <- lookupName dflags env overloadedNaturalsMN "fromNatural"+ fromCharName <- lookupName dflags env overloadedCharsMN "fromChar"+ nilName <- lookupName dflags env overloadedListsMN "nil"+ consName <- lookupName dflags env overloadedListsMN "cons"+ ifteName <- lookupName dflags env overloadedIfMN "ifte"+ fromLabelName <- lookupName dflags env ghcOverloadedLabelsMN "fromLabel"++ return Names {..}++lookupName :: GHC.DynFlags -> GHC.HscEnv -> GHC.ModuleName -> String -> TcM.TcM GHC.Name+lookupName dflags env mn vn = do+ res <- liftIO $ Finder.findImportedModule env mn Nothing+ case res of+ GHC.Found _ md -> IfaceEnv.lookupOrig md (GHC.mkVarOcc vn)+ _ -> do+ liftIO $ GHC.putLogMsg dflags GHC.NoReason Err.SevError noSrcSpan (GHC.defaultErrStyle dflags) $+ GHC.text "Cannot find module" GHC.<+> GHC.ppr mn+ fail "panic!"++-- | Module name and variable name+data VarName = VN String String+ deriving (Eq, Show)++lookupVarName :: GHC.DynFlags -> GHC.HscEnv -> VarName -> TcM.TcM GHC.Name+lookupVarName dflags env (VN vn mn) = lookupName dflags env (GHC.mkModuleName vn) mn++-------------------------------------------------------------------------------+-- diagnostics+-------------------------------------------------------------------------------++warn :: MonadIO m => GHC.DynFlags -> SrcSpan -> GHC.SDoc -> m ()+warn dflags l doc =+ liftIO $ GHC.putLogMsg dflags GHC.NoReason Err.SevWarning l (GHC.defaultErrStyle dflags) doc+ -- GHC.text "parsed string"+ -- GHC.$$+ -- GHC.ppr fs++debug :: MonadIO m => String -> m ()+-- debug = liftIO . putStrLn+debug _ = pure ()++-------------------------------------------------------------------------------+-- V2+-------------------------------------------------------------------------------++data V2 a = V2 a a+ deriving (Eq, Show)
+ src/Overloaded/Symbols.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Another way to desugar overloaded string literals. See 'FromSymbol'.+module Overloaded.Symbols (+ FromSymbol (..),+ ) where++import Data.Proxy (Proxy (..))+import Data.String (fromString)+import Data.Symbol.Ascii (ToList)+import GHC.Exts (Constraint)+import GHC.TypeLits+ (ErrorMessage (..), KnownSymbol, Symbol, TypeError, symbolVal)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++-- | Another way to desugar overloaded string literals using this class.+--+-- A string literal @"example"@ is desugared to+--+-- @+-- 'fromSymbol' \@"example"+-- @+--+-- Enabled with:+--+-- @+-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Symbols #-}+-- @+--+class FromSymbol (s :: Symbol) a where+ fromSymbol :: a++-------------------------------------------------------------------------------+-- base+-------------------------------------------------------------------------------++instance (KnownSymbol s, a ~ Char) => FromSymbol s [a] where+ fromSymbol = symbolVal (Proxy :: Proxy s)++-------------------------------------------------------------------------------+-- text+-------------------------------------------------------------------------------++instance KnownSymbol s => FromSymbol s T.Text where+ fromSymbol = fromString (symbolVal (Proxy :: Proxy s))++instance KnownSymbol s => FromSymbol s TL.Text where+ fromSymbol = fromString (symbolVal (Proxy :: Proxy s))++-------------------------------------------------------------------------------+-- bytestring+-------------------------------------------------------------------------------++type family SeqList (xs :: [Symbol]) :: Constraint where+ SeqList '[] = ()+ SeqList (x ': xs) = SeqList xs+ SeqList xs = TypeError ('Text "Cannot reduce list " ':$$: 'ShowType xs)++instance (KnownSymbol s, SeqList (ToList s)) => FromSymbol s BS.ByteString where+ fromSymbol = fromString (symbolVal (Proxy :: Proxy s))++instance (KnownSymbol s, SeqList (ToList s)) => FromSymbol s BSL.ByteString where+ fromSymbol = fromString (symbolVal (Proxy :: Proxy s))
+ test/Overloaded/Test/Chars.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Chars #-}+module Overloaded.Test.Chars where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++tests :: TestTree+tests = testGroup "Chars"+ [ testCase "Char" $+ 'x' @?= ('x' :: Char)+ ]
+ test/Overloaded/Test/If.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:If #-}+module Overloaded.Test.If where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++tests :: TestTree+tests = testGroup "If"+ [ testCase "Bool" $+ (if True then 'x' else 'y') @?= 'x'+ , testCase "Either" $+ (if Left () then 'x' else 'y') @?= 'y'+ ]
+ test/Overloaded/Test/Labels.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Labels=Overloaded.Symbols.fromSymbol #-}+module Overloaded.Test.Labels where++import Data.Proxy (Proxy (..))+import GHC.Exts (Constraint)+import GHC.TypeLits+ (ErrorMessage (..), KnownSymbol, Symbol, TypeError, symbolVal)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Overloaded++newtype NES = NES String deriving (Eq, Show)++type family NotEmptySymbol (s :: Symbol) :: Constraint where+ NotEmptySymbol "" = TypeError ('ShowType NES ':<>: 'Text " should not be empty")+ NotEmptySymbol s = ()++instance (KnownSymbol s, NotEmptySymbol s) => FromSymbol s NES where+ fromSymbol = NES $ symbolVal (Proxy :: Proxy s)++tests :: TestTree+tests = testGroup "Labels"+ [ testCase "NES" $+ #foo @?= NES "foo"+ ]
+ test/Overloaded/Test/Labels/GenericLens.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedLabels #-}+{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Labels=Data.Generics.Product.Fields.field #-}+module Overloaded.Test.Labels.GenericLens where++import Control.Lens (over, view)+import GHC.Generics (Generic)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++data Person = Person+ { name :: String+ , age :: Int+ , pet :: Pet+ }+ deriving (Eq, Show, Generic)++data Pet = Pet+ { petName :: String+ , petAge :: Int+ }+ deriving (Eq, Show, Generic)++sally :: Person+sally = Person+ { name = "Sally"+ , age = 21+ , pet = Pet+ { petName = "Bob"+ , petAge = 3+ }+ }++sally' :: Person+sally' = Person+ { name = "Sally"+ , age = 21+ , pet = Pet+ { petName = "Bob"+ , petAge = 4+ }+ }++newtype NES = NES String deriving (Eq, Show)+tests :: TestTree+tests = testGroup "Labels.GenericLens"+ [ testCase "view" $+ view (#pet . #petName) sally @?= "Bob"+ , testCase "over" $+ over (#pet . #petAge) succ sally @?= sally'+ ]
+ test/Overloaded/Test/Lists.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Lists #-}+module Overloaded.Test.Lists where++import Data.List.NonEmpty (NonEmpty (..))+import Data.SOP.BasicFunctors (I (..))+import Data.SOP.NP (NP (..), POP (..))+import Data.Vec.Lazy (Vec (..))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import qualified Data.Map as Map+import qualified Data.Type.Nat as N++import Overloaded.Lists++int :: Int+int = 1++tests :: TestTree+tests = testGroup "Lists"+ [ testCase "[]" $+ [1,2,3] @?= ([1,2,3] :: [Int])++ , testCase "NonEmpty" $+ [1,2,3] @?= int :| [2,3]++ , testCase "Vec" $+ [1,2,3] @?= int ::: 2 ::: 3 ::: VNil++-- Patterns not supported+-- , testCase "Vec pattern-match" $do+-- let res = case [1,2,3] :: Vec N.Nat3 Int of+-- [x,y,z] -> x + y + z+--+-- res @?= 6++ , testCase "NP" $ do+ let np :: NP I '[Int, Bool, String]+ np = [I 1, I True, I "YES"]++ np @?= I 1 :* I True :* I "YES" :* Nil++ , testCase "POP" $ do+ let pop :: POP I '[ '[Int, Bool], '[String] ]+ pop = [[I 0, I False], [I "NO"]]++ pop @?= POP ((I 0 :* I False :* Nil) :* (I "NO" :* Nil) :* Nil)++ , testCase "Map inline" $ do+ let m :: M Int Char+ m = [1, 'x', 3, 'y', 2, 'z']++ m @?= M (Map.fromList [(1,'x'),(2,'z'),(3,'y')])++ , testCase "Map pairs" $ do+ let m :: N Int Char+ m = [(1, 'x'), (3, 'y'), (2, 'z')]++ m @?= N (Map.fromList [(1,'x'),(2,'z'),(3,'y')])+ ]++-------------------------------------------------------------------------------+-- Map inline+-------------------------------------------------------------------------------++newtype M k v = M (Map.Map k v)+ deriving (Eq, Show)++newtype M' k v = M' (k -> Map.Map k v)++instance Nil (M k v) where+ nil = M Map.empty++instance Ord k => Cons v (M k v) (M' k v) where+ cons v (M m) = M' (\k -> Map.insert k v m)++instance Cons k (M' k v) (M k v) where+ cons k (M' km) = M (km k)++-------------------------------------------------------------------------------+-- Map pairs+-------------------------------------------------------------------------------++newtype N k v = N (Map.Map k v)+ deriving (Eq, Show)++instance Nil (N k v) where+ nil = N Map.empty++instance Ord k => Cons (k,v) (N k v) (N k v) where+ cons (k,v) (N m) = N (Map.insert k v m)
+ test/Overloaded/Test/Naturals.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Naturals #-}+module Overloaded.Test.Naturals where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import Numeric.Natural (Natural)++tests :: TestTree+tests = testGroup "Naturals"+ [ testCase "Natural" $+ 2 @?= (2 :: Natural)+ , testCase "Integer" $+ 3 @?= (3 :: Integer)+ ]
+ test/Overloaded/Test/Numerals.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DataKinds #-}+{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Numerals #-}+module Overloaded.Test.Numerals where++import Data.Fin (Fin (..))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import qualified Data.Type.Nat as N++tests :: TestTree+tests = testGroup "Numerals"+ [ testCase "Fin" $ do+ let f :: Fin (N.FromGHC 5)+ f = 2++ f @?= FS (FS FZ)++ , testCase "Fin pattern-match" $ do+ let res = case 2 :: Fin (N.FromGHC 5) of+ 2 -> True -- works, because there is @Num (Fin n)@ instance+ _ -> False+ res @?= True+ ]
+ test/Overloaded/Test/Strings.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Strings #-}+module Overloaded.Test.Strings where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Data.Text (Text, pack)++tests :: TestTree+tests = testGroup "Strings"+ [ testCase "String" $+ "Example" @?= ("Example" :: String)+ , testCase "Text" $+ "Example" @?= pack "Example"+ ]
+ test/Overloaded/Test/Symbols.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Symbols #-}+module Overloaded.Test.Symbols where++import Data.Proxy (Proxy (..))+import GHC.Exts (Constraint)+import GHC.TypeLits+ (ErrorMessage (..), KnownSymbol, Symbol, TypeError, symbolVal)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Overloaded++newtype NES = NES String deriving (Eq, Show)++type family NotEmptySymbol (s :: Symbol) :: Constraint where+ NotEmptySymbol "" = TypeError ('ShowType NES ':<>: 'Text " should not be empty")+ NotEmptySymbol s = ()++instance (KnownSymbol s, NotEmptySymbol s) => FromSymbol s NES where+ fromSymbol = NES $ symbolVal (Proxy :: Proxy s)++tests :: TestTree+tests = testGroup "Symbols"+ [ testCase "NES" $+ "foo" @?= NES "foo"+ ]
+ test/Tests.hs view
@@ -0,0 +1,27 @@+module Main (main) where++import Test.Tasty (defaultMain, testGroup)++import qualified Overloaded.Test.Chars as Chr+import qualified Overloaded.Test.If as Iff+import qualified Overloaded.Test.Labels as Lbl+import qualified Overloaded.Test.Lists as Lst+import qualified Overloaded.Test.Naturals as Nat+import qualified Overloaded.Test.Numerals as Num+import qualified Overloaded.Test.Strings as Str+import qualified Overloaded.Test.Symbols as Sym++import qualified Overloaded.Test.Labels.GenericLens as GL++main :: IO ()+main = defaultMain $ testGroup "Tests"+ [ Chr.tests+ , Iff.tests+ , Lbl.tests+ , Lst.tests+ , Nat.tests+ , Num.tests+ , Str.tests+ , Sym.tests+ , GL.tests+ ]