{-# LANGUAGE Rank2Types, ScopedTypeVariables,
MultiParamTypeClasses, DeriveDataTypeable,
GeneralizedNewtypeDeriving, TemplateHaskell, CPP #-}{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-name-shadowing #-}------------------------------------------------------------------------------- |-- Module : Data.Param.FSVec-- Copyright : (c) 2008 Alfonso Acosta, Oleg Kiselyov, Wolfgang Jeltsch-- and KTH's SAM group -- License : BSD-style (see the file LICENSE)-- -- Maintainer : alfonso.acosta@gmail.com-- Stability : experimental-- Portability : non-portable---- 'FSVec': Fixed sized vectors. Vectors with numerically parameterized size.---- Tutorial: <http://www.ict.kth.se/forsyde/files/tutorial/tutorial.html#FSVec>----------------------------------------------------------------------------moduleData.Param.FSVec(FSVec,empty,(+>),singleton,vectorCPS,vectorTH,-- #if __GLASGOW_HASKELL__ >= 609-- v,-- #endifunsafeVector,reallyUnsafeVector,readFSVec,readFSVecCPS,length,genericLength,lengthT,fromVector,null,(!),replace,head,last,init,tail,take,drop,select,group,(<+),(++),map,zipWith,foldl,foldr,zip,unzip,shiftl,shiftr,rotl,rotr,concat,reverse,iterate,generate,copy)whereimportData.TypeLevel.Numhiding((-),(+),(*),(>),(<),(>=),(<=),(==))importData.TypeLevel.Num.Aliases.TH(dec2TypeLevel)importData.Data(Data,Typeable,dataTypeOf,toConstr,gunfold,gfoldl,mkConstr,mkDataType,Fixity(..))importqualifiedPreludeasPimportPreludehiding(null,length,head,tail,last,init,take,drop,(++),map,foldl,foldr,zipWith,zip,unzip,concat,reverse,iterate)importqualifiedData.FoldableasDF(Foldable,foldr)importqualifiedData.TraversableasDT(Traversable(traverse))importLanguage.Haskell.THimportLanguage.Haskell.TH.Syntax(Lift(..))-- #if __GLASGOW_HASKELL__ >= 609-- import Language.Haskell.TH.Quote-- #endif-- | Fixed-Sized Vector data type, indexed with type-level naturals, the -- first index for all vectors is 0newtypeNats=>FSVecsa=FSVec{unFSVec::[a]}deriving(Eq,Typeable)instance(Dataa,Typeables)=>Data(FSVecsa)wheredataTypeOf(_)=tFSVectoConstr(FSVec_)=cFSVecgunfoldkz(_)=k(zFSVec)gfoldlkz(FSVeca1)=(zFSVec`k`a1)cFSVec=mkConstrtFSVec"FSVec"["unFSVec"]PrefixtFSVec=mkDataType"Data.Param.FSVec"[cFSVec]instanceShowa=>Show(FSVecsa)whereshowsPrec_=showV.unFSVecwhereshowV[]=showString"<>"showV(x:xs)=showChar'<'.showsx.showlxswhereshowl[]=showChar'>'showl(x:xs)=showChar','.showsx.showlxs--------------------------- Constructing functions-------------------------empty::FSVecD0aempty=FSVec[]-- | Cons operator, note it's not a constructor(+>)::(Nats,Poss',Succss')=>a->FSVecsa->FSVecs'ax+>(FSVecxs)=FSVec(x:xs)infixr5+>-- | A FSVec with a single elementsingleton::a->FSVecD1asingletonx=x+>empty-- | Build a vector from a list (CPS style)vectorCPS::[a]->(foralls.Nats=>FSVecsa->w)->wvectorCPSxs=unsafeVectorCPS(P.lengthxs)xs-- | Build a vector from a list (using Template Haskell)vectorTH::Lifta=>[a]->ExpQvectorTHxs=(vectorCPSxs)lift#if __GLASGOW_HASKELL__ >= 609-- -- | Vector quasiquoter-- v :: QuasiQuoter-- v = undefined-- -- v = QuasiQuoter (fst.parseFSVecExp) parseFSVecPat-- -- -- Build a vector using quasiquotation-- -- Not possible in the general case! It is feasible, though, when only -- -- allowing monomorphic vectors. For example, in the case of Ints:-- -- parseFSVecExp :: String -> ExpQ-- -- parseFSVecExp str = (readFSVec str) (lift :: Nat s => FSVec s Int -> ExpQ)-- parseFSVecExp :: forall a . String -> (ExpQ, a)-- parseFSVecExp str = ((readFSVec str) (lift :: (Nat s, Lift a) => FSVec s a -> ExpQ), undefined) -- -- -- Pattern match a vector using quasiquotation-- parseFSVecPat :: String -> PatQ-- parseFSVecPat = error "Data.Param.FSVec: quasiquoting paterns not supported"-- -- -- __GLASGOW_HASKELL__#endif -- | Build a vector from a list (unsafe version: The static/dynamic size of -- the list is checked to match at runtime)unsafeVector::Nats=>s->[a]->FSVecsaunsafeVectorlxs|toNuml/=P.lengthxs=error(show'unsafeVectorP.++": dynamic/static length mismatch")|otherwise=FSVecxs-- | Build a vector from a list. -- -- Unlike unsafeVector, reallyunsafeVector doesn't have access to the -- static size of the list and thus cannot not check it against its-- dynamic size (which saves traversing the list at runtime to obtain -- the dynamic length).---- Therefore, reallyUnsafeVector (the name is that long on purspose)-- can be used to gain some performance but may break the consistency-- of the size parameter if not handled with care (i.e. the size-- parameter can nolonger be checked statically and the fullfilment of-- function constraints is left to the programmers judgement).-- -- Do not use reallyUnsafeVector unless you know what you're doing!reallyUnsafeVector::[a]->FSVecsareallyUnsafeVector=FSVec-- | Read a vector (Note the the size of -- the vector string is checked to match the resulting type at runtime)readFSVec::(Reada,Nats)=>String->FSVecsareadFSVec=readinstance(Reada,Nats)=>Read(FSVecsa)wherereadsPrec_str|allfitsLengthposibilities=P.maptoReadSposibilities|otherwise=error(fNameP.++": string/dynamic length mismatch")wherefName="Data.Param.FSVec.read"expectedL=toInt(undefined::s)posibilities=readFSVecListstrfitsLength(_,l,_)=l==expectedLtoReadS(xs,_,rest)=(FSVecxs,rest)-- | Read a vector, CPS version.readFSVecCPS::Reada=>String->(foralls.Nats=>FSVecsa->w)->wreadFSVecCPSstr=unsafeVectorCPSlxswherefName=show'readFSVecCPS(xs,l)=case[(xs,l)|(xs,l,rest)<-readFSVecListstr,("","")<-lexFSVecrest]of[(xs,l)]->(xs,l)[]->error(fNameP.++": no parse")_->error(fNameP.++": ambiguous parse")------------------------ Observing functions------------------------ | value-level length of a vector length::forallsa.Nats=>FSVecsa->Intlength_=toInt(undefined::s)-- | generic value-level length of a vector genericLength::forallsan.(Nats,Numn)=>FSVecsa->ngenericLength_=toNum(undefined::s)-- | type-level version of lengthlengthT::Nats=>FSVecsa->slengthT=undefined-- | Transform Vector to a listfromVector::Nats=>FSVecsa->[a]fromVector(FSVecxs)=xs-- | Check if a Vector is emptynull::FSVecD0a->Boolnull_=True-- Note: This definition checks the length at _runtime_, we don't want it-- null (FSVec []) = True-- null _ = False-- | Access an element of a vector(!)::(Poss,Nati,i:<:s)=>FSVecsa->i->a(FSVecxs)!i=xs!!(toInti)--------------------------- Transforming functions--------------------------- | Replace an element of a vectorreplace::(Nats,Nati)=>FSVecsa->i->a->FSVecsa-- alternative, more restrictive type -- replace :: (Pos s, Nat i, n :<: s) => FSVec s a -> i -> a -> FSVec s areplace(FSVecxs)iy=FSVec$replace'xs(toInti)ywherereplace'[]__=[]replace'(_:xs)0y=(y:xs)replace'(x:xs)ny=x:(replace'xs(n-1)y)-- | Take the first element of a vectorhead::Poss=>FSVecsa->ahead=P.head.unFSVec-- | Take the last element of a vectorlast::Poss=>FSVecsa->alast=P.last.unFSVec-- | Return all but the first element of a vectortail::(Poss,Succs's)=>FSVecsa->FSVecs'atail=liftVP.tail-- | Return all but the last element of a vectorinit::(Poss,Succs's)=>FSVecsa->FSVecs'ainit=liftVP.init-- | Take the first i elements of a vectortake::(Nati,Nats,Minsis')=>i->FSVecsa->FSVecs'atakei=liftV$P.take(toInti)-- | Drop the first i elements of a vectordrop::(Nati,Nats,Minsism,Subssms')=>i->FSVecsa->FSVecs'adropi=liftV$P.drop(toInti)-- | The function 'select' selects elements in the vector. The first argument-- gives the initial element, starting from zero, the second argument gives the-- stepsize between elements and the last argument gives the number of -- elements.select::(Natf,Nats,Natn,f:<:i,{- f + s * n <= i -}Mulsnsmn,Addfsmnfasmn,fasmn:<=:i)=>f->s->n->FSVecia->FSVecnaselectfsn=liftV(select'f's'n')where(f',s',n')=(toIntf,toInts,toIntn)select'fsn=((selectFirst0sn).(P.dropf))-- list version of select assuming 0 is the index for the first elementselectFirst0::Int->Int->[a]->[a]selectFirst0snl@(x:_)|n>0=x:selectFirst0s(n-1)(P.dropsl)|otherwise=[]selectFirst0_0[]=[]-- | break a vector into subvectors of size n.group::(Posn,Nats,Divsns')=>n->FSVecsa->FSVecs'(FSVecna)groupn=liftV(group'(toIntn))wheregroup'::Int->[a]->[FSVecsa]group'nxs=casesplitAtMnxsofNothing->[]Just(ls,rs)->FSVecls:group'nrs-- | add an element at the end of a vector. (Inverse of '(+>)') (<+)::(Nats,Poss',Succss')=>FSVecsa->a->FSVecs'a-- This should work, but it doesn't because-- "Could not deduce (Data.TypeLevel.Num.Ops.Add' s D1 s')-- from the context (Nat s, Pos s', Succ s s')"-- xs <+ x = xs Data.Param.FSVec.++ (singleton x)(<+)(FSVecxs)x=FSVec(xsP.++[x])-- | Concatenate two vectors(++)::(Nats1,Nats2,Adds1s2s3)=>FSVecs1a->FSVecs2a->FSVecs3a(++)=liftV2(P.++)infixl5<+infixr5++-- | Apply a function on all elements of a vectormap::Nats=>(a->b)->FSVecsa->FSVecsbmapf=liftV(P.mapf)-- | Applies function pairwise on two vectorszipWith::Nats=>(a->b->c)->FSVecsa->FSVecsb->FSVecsczipWithf=liftV2(P.zipWithf)-- | Folds a function from the right to the left over a vector using an-- initial value.foldl::Nats=>(a->b->a)->a->FSVecsb->afoldlfe=(P.foldlfe).unFSVec-- | Folds a function from the left to the right over a vector using an -- initial value.foldr::Nats=>(b->a->a)->a->FSVecsb->afoldrfe=(P.foldrfe).unFSVec-- 'filter' takes a predicate function and a vector and creates a new vector -- with the elements for which the predicate is true. -- filterV :: (a -> Bool) -> Vector a -> Vector a-- FIXME: -- Imposible to define, the result does not have a predictable static size-- | zip two vectors into a vector of tuples.zip::Nats=>FSVecsa->FSVecsb->FSVecs(a,b)zip=liftV2P.zip-- | unzip a vector of tuples into two vectors.unzip::Nats=>FSVecs(a,b)->(FSVecsa,FSVecsb)unzip(FSVecxs)=let(a,b)=P.unzipxsin(FSVeca,FSVecb)-- | shift a value from the left into a vector. shiftl::Poss=>FSVecsa->a->FSVecsa-- This doesn't work-- shiftl xs x = x +> init xsshiftlxsx=liftV((x:).P.init)xs-- | shift a value from the left into a vector. shiftr::Poss=>FSVecsa->a->FSVecsa-- This doesn't work-- shiftr xs x = tail xs <+ xshiftrxsx=liftV(P.tail.(P.++[x]))xs-- | Rotate a vector to the left. Note that this fuctions does not change the -- size of a vector.rotl::forallsa.Nats=>FSVecsa->FSVecsa-- This doesn't work (it's highly inneficient anyway)-- rotl [] = []-- rotl vs = lastV vs +> initV vs rotl=liftVrotl'wherevl=toInt(undefined::s)rotl'[]=[]rotl'xs=let(i,[l])=splitAt(vl-1)xsinl:i-- | Rotate a vector to the left. Note that this fuctions does not change the -- size of a vector.rotr::Nats=>FSVecsa->FSVecsa-- This doesn't work -- rotr [] = []-- rotr vs = tailV vs <: headV vsrotr=liftVrotr'whererotr'[]=[]rotr'l@(x:_)=P.taillP.++[x]-- | flatten a vector of vectors to a single vectorconcat::(Nats1,Nats2,Nats3,Muls1s2s3)=>FSVecs1(FSVecs2a)->FSVecs3a-- this won't work: -- concat = foldr (++) emptyconcat=liftV(P.foldr((P.++).unFSVec)[])-- | reverse a vectorreverse::Nats=>FSVecsa->FSVecsareverse=liftVP.reverse-- | generate a vector with a given number of elements starting from an -- initial element using a supplied function for the generation of elements. ---- > FSVec> iterate d5 (+1) 1---- > <1,2,3,4,5> :: Num a => FSVec D5 aiterate::Nats=>s->(a->a)->a->FSVecsaiteratesfx=lets'=toIntsinFSVec(P.takes'$P.iteratefx)-- | 'generate' behaves in the same way as 'iterate', but starts with the -- application of the supplied function to the supplied value. ---- > FSVec> generate d5 (+1) 1-- -- > <2,3,4,5,6> :: Num a => FSVec D5 agenerate::Nats=>s->(a->a)->a->FSVecsageneratesfx=lets'=toIntsinFSVec(P.takes'$P.tail$P.iteratefx)-- | generates a vector with a given number of copies of the same element. ---- > FSVec> copy d7 5 -- -- > <5,5,5,5,5,5,5> :: FSVec D7 Integercopy::Nats=>s->a->FSVecsacopysx=iteratesidx-------------- Instances------------instanceNats=>DF.Foldable(FSVecs)wherefoldr=foldrinstanceNats=>Functor(FSVecs)wherefmap=mapinstanceNats=>DT.Traversable(FSVecs)wheretraversef=(fmapFSVec).(DT.traversef).unFSVecinstance(Lifta,Nats)=>Lift(FSVecsa)wherelift(FSVecxs)=[|unsafeFSVecCoerce$(undefSigElengthType)(FSVecxs)|]where-- Get the vector length in a type-level decimallengthType::TypeQlengthType=dec2TypeLevel$toInt(undefined::s)----------------------- Internal functions----------------------- the FSVec equivalent of liftM-- note it is unsafe and shouldn't be exportedliftV::([a]->[b])->FSVecsa->FSVecs'bliftVf=FSVec.f.unFSVec-- the FSVec equivalent of liftM-- note it is unsafe and shouldn't be exportedliftV2::([a]->[b]->[c])->FSVecs1a->FSVecs2b->FSVecs3cliftV2fab=FSVec(f(unFSVeca)(unFSVecb))-- version of splitAt which checks if the list contains enough elementssplitAtM::Int->[a]->Maybe([a],[a])splitAtMnxs=splitAtM'n[]xswheresplitAtM'0xsys=Just(xs,ys)splitAtM'nxs(y:ys)|n>0=do(ls,rs)<-splitAtM'(n-1)xsysreturn(y:ls,rs)splitAtM'___=Nothing-- Arbitraly coerce the length parameter of a vectorunsafeFSVecCoerce::s'->FSVecsa->FSVecs'aunsafeFSVecCoerce_(FSVecv)=(FSVecv)-- Obtain a TH expression of undefined coerced to certain typeundefSigE::TypeQ->ExpQundefSigEt=sigE[|undefined|]t-- unsafely (a trusted length is provided) create a vector using CPS styleunsafeVectorCPS::forallaw.Int->[a]->(foralls.Nats=>FSVecsa->w)->wunsafeVectorCPSlxsf=reifyIntegrall(\(_::lt)->f((FSVecxs)::(FSVeclta)))-- Modified version of Prelude.readList which accepts < > instead-- of [ ] to read lists and also provides the list lengthreadFSVecList::Reada=>String->[([a],Int,String)]readFSVecList=readParen'False(\r->[pr|("<",s)<-lexFSVecr,pr<-readls])wherereadls=[([],0,t)|(">",t)<-lexFSVecs]P.++[(x:xs,1+n,u)|(x,t)<-readss,(xs,n,u)<-readl't]readl's=[([],0,t)|(">",t)<-lexFSVecs]P.++[(x:xs,1+n,v)|(",",t)<-lexs,(x,u)<-readst,(xs,n,v)<-readl'u]readParen'bg=ifbthenmandatoryelseoptionalwhereoptionalr=grP.++mandatoryrmandatoryr=[(x,n,u)|("(",s)<-lexFSVecr,(x,n,t)<-optionals,(")",u)<-lexFSVect]-- Custom lexer for FSVecs, we cannot use lex directly because it considers-- sequences of < and > as unique lexemes, and that breaks nested FSVecs, e.g.-- <<1,2><3,4>>lexFSVec::ReadSStringlexFSVec('>':rest)=[(">",rest)]lexFSVec('<':rest)=[("<",rest)]lexFSVecstr=lexstr